使用 Excel 值作为文件名的输入保存电子邮件附件

Question

我对编码有点陌生，但这里是 :)

我收到了需要使用 Excel 工作表中的信息以特定名称格式保存的电子邮件附件。

• 包含我需要的信息的行可以通过电子邮件的主题行来识别。

我想为 Outlook 中选定的电子邮件编写一些代码来执行以下操作：

1. 使用电子邮件的主题行查找包含所需信息的行
2. 从该行中的多个字段返回值
3. 使用这些值和主题行来创建文件名
4. 将文件保存到指定目录

我设法找到并重写了一些复制的代码，以仅使用主题行作为文件名来保存附件。我正在努力从 Excel 表中获取信息以将其附加到文件名中。

到目前为止，这是我的代码：

Sub SaveAttachments()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strFileName As String
Dim objSubject As String
Dim strDeletedFiles As String 


strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next

' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")

' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

' Set the Attachment folder.
strFolderpath = "C:\Users\User\Documents\"

' Check each selected item for attachments.
For Each objMsg In objSelection

'Set FileName to Subject
objSubject = objMsg.Subject

Set objAttachments = objMsg.Attachments

lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1

' Get the file name.
strFileName = objSubject & ".pdf"

' Combine with the path to the Temp folder.
strFile = strFolderpath & strFileName
Debug.Print strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

我猜我需要编写一个函数来返回 Excel 工作表中的值，但我不知道该怎么做。

Answer 1

为了让您的代码尽可能整洁，让我们创建一个函数来从 Excel 工作表中获取信息：

1. 使用主题查找包含所需信息的行 电子邮件行
2. 从该行中的多个字段返回值
3. 使用这些值和主题行创建文件名
4. 将文件保存到指定目录

假设主题行

Function GetInfoFromWorksheet(ws as Worksheet, mail as Outlook.MailItem)
'  Finds a subject in the worksheet and returns the concatenated
'   values from several cells in that row
'  worksheet:  the sheet which contains the outlook info/details
'  mail:       the outlook mailitem being processed


    Dim row as Long
    Dim rng as Range
    Dim combinedValues as String
    Dim subject as String
    Dim ret As String

    subject = mail.Subject
    '#1 Find the subject in Column A, modify if needed
    Set rng = Application.Match(subject, ws.Range("A:A"), False)
    If not rng Is Nothing Then
        row = rng.Row
    Else
        ret = ""
        GoTo EarlyExit
    End If

    '#2, #3 Once we know the row, then you can pull out additional info
    '   from this row and combine them like so.
    '   Example combines column B and Column F, modify as needed:
     ret = ws.Cells(row, 2) & ws.Cells(row, 6) 'Etc


EarlyExit:
    SaveAttachments = ret
End Function

从你的过程中，这样称呼它：

For i = lngCount To 1 Step -1
    ' Get the file name.
     strFileName = GetInfoFromWorksheet(ActiveSheet, objMsg)
     If strFileName = "" Then 
         ' the function returns an empty string, then the subject wasn't found in Excel sheet
          MsgBox objMsg & " not found in Excel sheet!", vbInformation


     Else:
         'the details were found in Excel, so save the file:
          strFileName = strFileName & ".pdf"
         ' Combine with the path to the Temp folder.
         strFile = strFolderpath & strFileName
         Debug.Print strFile
         ' Save the attachment as a file.
         objAttachments.Item(i).SaveAsFile strFile
     End If
Next

注意：这可能不适用于具有多个附件的项目，因为与主题行匹配的行对于每个附件都是相同的，因此它会返回相同的信息，您将最终每个附件都有相同的文件名。您可以轻松地修改函数或调用过程以将i 值附加到文件名，从而确保每个附件的名称都是唯一的。喜欢：

     'the details were found in Excel, so save the file:
      strFileName = strFileName & Cstr(i) & ".pdf"

另一个注意事项：摆脱On Error Resume Next并正确处理错误...