如何使用电子邮件的主题行将附件分类到本地文件夹中？

Question

我收到带有附件的自动电子邮件。不同的客户由主题行标识。
我将附件拖放到新电子邮件中并将其发送给相应的客户。

我想自动化这个过程，以便我可以点击并自动为每个客户生成包含适当附件的电子邮件。

我拼凑了一些我在互联网上找到的东西。它适用于一位客户。
它遍历子文件夹（Test2）并将每个附件复制到我机器上的本地文件（test2），然后生成一封电子邮件并将本地文件夹中的所有项目附加到新电子邮件中，并将电子邮件发送到 X。

Send()
    SaveEmailAttachmentsToFolder "Test Folder2", "pdf", "C:\Users\UserName\Desktop\test2"
End Sub
    
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, destFolder As String)
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim item As Object
    Dim Atmt As Attachment
    
    Dim FileName As String
    Dim MyDocPath As String
    Dim i As Integer
    Dim wsh As Object
    Dim fs As Object

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    i = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
            vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.item("mydocuments")
        destFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If

    If Right(destFolder, 1) <> "\" Then
        destFolder = destFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each item In SubFolder.Items
        For Each Atmt In item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = destFolder & item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next item

    ' Show this message when Finished
    If i > 0 Then
        MsgBox "You can find the files here : " _
             & destFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ''This portion generates the email
    '' pulls the attachments from local test 2 folder
    '' sends email to specified email address

    Dim mess_body As String, StrFile As String, StrPath As String
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem

    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

    '~~> Change path here
    StrPath = "C:\Users\KTucker\Desktop\test2\"
    
    With MailOutLook
        .BodyFormat = olFormatRichText
        .To = "Email@email.com"
        .Subject = "This an email subject"
        .HTMLBody = "This is an email body"


        '~~> *.* for all files
        StrFile = Dir(StrPath + "*.*")

        Do While Len(StrFile) > 0
            .Attachments.Add StrPath & StrFile
            StrFile = Dir
        Loop

        '.DeleteAfterSubmit = True
        .Send
    End With

    MsgBox "Reports have been sent", vbOKOnly
    
    'Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub
    
    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

上半部分复制“Test Folder2”子文件夹中的所有附件，然后将其保存到“Desktop/Test2”文件夹。
后半部分生成新邮件，将本地Test2文件中的所有文档拉取并附加到新邮件中，然后发送到指定地址。

我可以在上半部分添加什么代码来解析相同的子文件夹（Test Folder2）并将具有一个主题行的电子邮件中的所有附件保存到一个本地文件夹，并将具有不同主题行的电子邮件中的所有附件保存到另一个文件夹？

Answer 1

根据 Item.Subject 创建子文件夹。

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, destFolderPath As String)

    Dim ns As NameSpace
    Dim Inbox As Folder
    Dim SubFolder As Folder

    Dim item As Object
    Dim Atmt As Attachment
    Dim FileName As String

    Dim i As Long

    Dim wsh As Object
    Dim fs As Object

    Dim itmSubjFldrName As String   ' Subfolder of destFolderPath
    Dim attFolderPath As String '

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    i = 0

    ' Check subfolder for messages and exit if none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Exit Sub
    End If

    If Right(destFolderPath, 1) <> "\" Then
        destFolderPath = destFolderPath & "\"
    End If

    Set wsh = CreateObject("WScript.Shell")
    Set fs = CreateObject("Scripting.FileSystemObject")

    ' Check each message for attachments and extensions
    For Each item In SubFolder.Items

        If item.Attachments.Count > 0 Then

            ' Simple example for
            '  determining a folder name based on subject.
            ' You must also remove characters not valid in a folder name
            '  for example the : in RE: and FW:
            itmSubjFldrName = Left(item.Subject, 20)

            attFolderPath = destFolderPath & itmSubjFldrName & "\"

            If Not fs.FolderExists(attFolderPath) Then
                fs.CreateFolder attFolderPath
            End If

            For Each Atmt In item.Attachments

                If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then

                    FileName = attFolderPath & item.SenderName & " " & Atmt.FileName
                    Atmt.SaveAsFile FileName

                    i = i + 1

                End If

            Next Atmt
        End If

    Next item

    ' Show this message when Finished
    If i > 0 Then
        MsgBox "You can find the files here : " _
             & destFolderPath, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

End Sub

Answer 2

 Set appOutLook = CreateObject("Outlook.Application")

首先，如果您在 Outlook 中运行宏，则无需在代码中创建新的 Outlook 应用程序实例。 Application 属性开箱即用。

我可以在上半部分添加什么代码来解析相同的子文件夹（Test Folder2）并将具有一个主题行的电子邮件中的所有附件保存到一个本地文件夹，并将具有不同主题行的电子邮件中的所有附件保存到另一个文件夹？

您似乎只需要根据Subject 属性在磁盘上创建一个子文件夹并将项目的附件保存在那里。例如，原始草图：

 'Create DestFolder if DestFolder = ""
    If destFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.item("mydocuments")
        destFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(destFolder) Then
            fs.CreateFolder destFolder
        End If
    End If

    If Right(destFolder, 1) <> "\" Then
        destFolder = destFolder & "\"
    End If

    ' Check each message for attachments and extensions
    Dim itemDestFolder as String
    For Each item In SubFolder.Items
        If item.Attachments.Count > 0 then 

           Set itemDestFolder = destFolder & "\" & item.Subject
           If Not fs.FolderExists(itemDestFolder) Then
              fs.CreateFolder itemDestFolder
           End If

           For Each Atmt In item.Attachments
             If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = itemDestFolder & item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
             End If
           Next Atmt
        End If
    Next item