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文件中的所有文档拉出并将其附加到新电子邮件中，然后将其发送到特定地址。

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

Answer 1

 Set appOutLook = CreateObject("Outlook.Application")

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

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

似乎您只需要根据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

Answer 2

要基于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

如何使用子文件夹中电子邮件的主题行来排序哪些电子邮件附件转到哪个本地文件夹？

2 个答案: