使用 VBA 自动化 - 根据多个条件将多个附件保存到特定文件夹答案

【问题标题】：Using VBA to Automate - Save multiple attachment based on multiple criteria to specific folders使用 VBA 自动化 - 根据多个条件将多个附件保存到特定文件夹
【发布时间】：2021-01-05 13:49:32
【问题描述】：

我根据以下标准向多个利益相关者（约 10 个）发送每日报告

标准 1：根据发件人以及来自电子邮件发件人和主题的 1 或 2 个关键字下载附件
标准 2：不包括周末，因为报告仅在工作日发送给相应的利益相关者并由其回复。
周一报告从周五的附件下载
标准 3：一家公司有 4 个区域，其余为集中式。
来自4个地区的公司的附件，将保存在公司标题下的文件夹中。
对于其余公司，附件将保存在其各自的公司文件夹名称中。
与仅限于公司名称和仅年月的父文件夹相比，文件的年、月和日将更具描述性。

以上所有都已尝试。我还需要创建自动化，每个文件夹最多只能保存 2 个月的文件，之后将为这些月份的附件创建另一个文件夹。

感谢我的代码笨拙，需要更快的版本。

Option Explicit

Sub SaveOutlookAttachments()

    Dim objOutlook As New Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objFolder As Outlook.folder
    Dim objItem As Object
    Dim objMailItem As Outlook.MailItem
    Dim objAttachment As Outlook.Attachment

    'For Folders creation

    Dim fso As Scripting.FileSystemObject
    Dim dir As Scripting.Folders
    Dim dirFolderName As String


    'For Date settings
    Dim iBackdate As Integer

    ' Hardcoding Partners - 
    Dim COMP_A_North As String
    Dim COMP_A_South As String
    Dim COMP_A_East As String
    Dim COMP_A_West As String
    Dim COMP_B As String
    Dim COMP_C As String
    Dim COMP_D As String
    Dim COMP_E As String
    Dim COMP_F As String


    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.Folders(1).Folders("Inbox")


    Set fso = New Scripting.FileSystemObject


    'Setting Partner Filters
 
    COMP_A_North = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Scotland%'"
    COMP_A_South = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%North%'"
    COMP_A_East = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Midlands%'"
    COMP_A_West = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%London%'"
    COMP_B = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compb%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
    COMP_C = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compc%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
    COMP_D = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compd%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
    COMP_E = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%compe%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
    COMP_F = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compf%'" & "AND 
    ""urn:schemas:httpmail:subject"" LIKE '%Missing%'"

 
        For Each objItem In objFolder.Items.Restrict(COMP_A_North)

        'Check Item Class
        If objItem.Class = Outlook.olMail Then

          'Set as Mail Item
           Set objMailItem = objItem

           With objMailItem
              Select Case Weekday(Now)
                  Case 7 ' Saturday: add extra day
                      iBackdate = 3
                  Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                  Case Else ' Other days
                    iBackdate = 2
                 End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                    ' Save Attachments
                    
                If objAttachment.Count > 0 Then
                
                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report UpTo" & 
                Format(objAttachment.receivetime, "yyyy-mm")
                
                  If fso.FolderExists(dirFolderName) Then
                      Set dir = fso.GetFolder(dirFolderName)
                  Else
                      Set dir = fso.CreateFolder(dirFolderName)
                  End If
                
                
                
                    For Each objAttachment In .Attachments
                        
        
                        
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
        objAttachment.FileName = "compa North and Iceland Region Report" & Format(.ReceivedTime, "yyyy- 
         mm- dd")   'Put in a valid folder location to store attachements


                    Next
                
                End If
            
            End If

        End With

    End If

    Next




        For Each objItem In objFolder.Items.Restrict(COMP_A_South)

        'Check Item Class
        If objItem.Class = Outlook.olMail Then

            'Set as Mail Item
             Set objMailItem = objItem

            With objMailItem
                Select Case Weekday(Now)
                    Case 7 ' Saturday: add extra day
                        iBackdate = 3
                    Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                        iBackdate = 4
                    Case Else ' Other days
                        iBackdate = 2
                End Select

                ' Check date
                If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                    ' Save Attachments
                    If objAttachment.Count > 0 Then
                
                    dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report 
                    UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
                
                    If fso.FolderExists(dirFolderName) Then
                        Set dir = fso.GetFolder(dirFolderName)
                    Else
                        Set dir = fso.CreateFolder(dirFolderName)
                    End If
                        
                        
                            For Each objAttachment In .Attachments
                            Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, 
                            objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
                            objAttachment.FileName = "compa South Region  Report" & 
                            Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid folder location to 
                            store attachements

                        Next

                End If
                
            End If

        End With

    End If

    Next


    For Each objItem In objFolder.Items.Restrict(COMP_A_East)

        'Check Item Class
        If objItem.Class = Outlook.olMail Then

            'Set as Mail Item
            Set objMailItem = objItem

            With objMailItem
                Select Case Weekday(Now)
                    Case 7 ' Saturday: add extra day
                        iBackdate = 3
                    Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                        iBackdate = 4
                    Case Else ' Other days
                        iBackdate = 2
                End Select

                ' Check date
                If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                    ' Save Attachments
                    If objAttachment.Count > 0 Then
                
                    dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report 
                UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
                
                    If fso.FolderExists(dirFolderName) Then
                        Set dir = fso.GetFolder(dirFolderName)
                    Else
                        Set dir = fso.CreateFolder(dirFolderName)
                    End If
                        
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
    objAttachment.FileName = "compa East Region  Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in 
    a valid folder location to store attachements

                        Next
                End If
                
            End If

        End With

    End If

    Next




    For Each objItem In objFolder.Items.Restrict(COMP_A_West)

        'Check Item Class
        If objItem.Class = Outlook.olMail Then

            'Set as Mail Item
            Set objMailItem = objItem

            With objMailItem
                Select Case Weekday(Now)
                    Case 7 ' Saturday: add extra day
                        iBackdate = 3
                    Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                        iBackdate = 4
                    Case Else ' Other days
                        iBackdate = 2
                End Select

                ' Check date
                If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                    ' Save Attachments
                    If objAttachment.Count > 0 Then
                
                    dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa  Report 
    UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
                
                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
      objAttachment.FileName = "compa West and Central Region  Report" & Format(.ReceivedTime, "yyyy-mm- 
      dd")   'Put in a valid folder location to store attachements

                        Next
                        
                End If
                
            End If

        End With

    End If

    Next




    For Each objItem In objFolder.Items.Restrict(COMP_B)

        'Check Item Class
        If objItem.Class = Outlook.olMail Then

            'Set as Mail Item
            Set objMailItem = objItem

            With objMailItem
                Select Case Weekday(Now)
                    Case 7 ' Saturday: add extra day
                        iBackdate = 3
                    Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                        iBackdate = 4
                    Case Else ' Other days
                        iBackdate = 2
                End Select

                ' Check date
                If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                            ' Save Attachments
                    If objAttachment.Count > 0 Then
                
                    dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompB Report 
    UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
                
                    If fso.FolderExists(dirFolderName) Then
                        Set dir = fso.GetFolder(dirFolderName)
                    Else
                        Set dir = fso.CreateFolder(dirFolderName)
                    End If
                        
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
    objAttachment.FileName = "compb Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
    folder location to store attachements

                        Next
                End If
            End If

        End With

    End If

    Next




    For Each objItem In objFolder.Items.Restrict(COMP_C)

        'Check Item Class
        If objItem.Class = Outlook.olMail Then

            'Set as Mail Item
            Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                ' Save Attachments
                If objAttachment.Count > 0 Then
                
                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompC  Report UpTo" & 
     Format(objAttachment.receivetime, "yyyy-mm")
                
                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
    objAttachment.FileName = "CompC Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
    folder location to store attachements

                        Next
                End If
            End If

        End With

    End If

    Next


    For Each objItem In objFolder.Items.Restrict(COMP_D)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                ' Save Attachments
                If objAttachment.Count > 0 Then
                
                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompD Report UpTo" & 
     Format(objAttachment.receivetime, "yyyy-mm")
                
                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
     objAttachment.FileName = "compd Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
     folder location to store attachements

                        Next
                End If
                
            End If

        End With

    End If

    Next




    For Each objItem In objFolder.Items.Restrict(COMP_E)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                ' Save Attachments
                If objAttachment.Count > 0 Then
                
                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompE  Report UpTo" & 
    Format(objAttachment.receivetime, "yyyy-mm")
                
                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        

                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
     objAttachment.FileName = "compe  Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
     folder location to store attachements

                        Next
                End If
                
            End If

        End With

    End If

    Next


     For Each objItem In objFolder.Items.Restrict(COMP_F)

    'Check Item Class
    If objItem.Class = Outlook.olMail Then

        'Set as Mail Item
        Set objMailItem = objItem

        With objMailItem
            Select Case Weekday(Now)
                Case 7 ' Saturday: add extra day
                    iBackdate = 3
                Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
                    iBackdate = 4
                Case Else ' Other days
                    iBackdate = 2
            End Select

            ' Check date
            If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            
                ' Save Attachments
                If objAttachment.Count > 0 Then
                
                dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompF  Report UpTo" & 
     Format(objAttachment.receivetime, "yyyy-mm")
                
                If fso.FolderExists(dirFolderName) Then
                    Set dir = fso.GetFolder(dirFolderName)
                Else
                    Set dir = fso.CreateFolder(dirFolderName)
                End If
                        
                        For Each objAttachment In .Attachments
                        Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
                        
                            objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" & 
    objAttachment.FileName = "compf Report" & Format(.ReceivedTime, "yyyy-mm-dd")   'Put in a valid 
     folder location to store attachements

                        Next
                End If
                
            End If
            
        End With

    End If

    Next

End Sub

【问题讨论】：

如果您希望任何人检查您的代码并找出任何问题，那真是太多的代码了。您是否面临特定问题？这里有什么问题？最好就一件具体的事情提出问题并准确描述它是什么。
@TimWilliams 你是对的，它很长。作为问题的一部分，我知道有些代码是重复的，我希望能得到一些帮助。我被困住了，目前仍在寻找其他方法。我需要帮助来简化上述标准完整的代码。非常感谢您的阅读。
有一堆重构可以让你的代码更易于维护（我可以稍后看看）但可能不会让它变得任何更快 - 它仍然会做同样的工作。
@TimWilliams，是的，请。任何帮助将不胜感激。我敢肯定还有其他人会利用您提供的答案。只要满足条件。上面提到的另一部分：我还需要创建自动化，其中每个文件夹最多只能保存 2 个月的文件，之后将创建另一个文件夹，其中包含将填充的那些月份的新附件。 - 我无法编写代码，但如果你能支持我，我将不胜感激。非常感谢

标签： vba outlook

【解决方案1】：

这就是我将如何重做它。已编译但未测试，因此如果不起作用，您可能需要进行一些调试。

Sub SaveOutlookAttachments()

    Dim objOutlook As New Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objFolder As Outlook.Folder

    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.Folders(1).Folders("Inbox")

    ProcessMails objFolder, "compa", "Scotland", "compa  Report UpTo", "compa Scotland Region Report"
    ProcessMails objFolder, "compa", "North", "compa  Report UpTo", "compa North Region Report"
    ProcessMails objFolder, "compa", "Midlands", "compa  Report UpTo", "compa Midlands Region Report"
    ProcessMails objFolder, "compa", "London", "compa  Report UpTo", "compa London Region Report"


End Sub

Sub ProcessMails(srcFolder As Outlook.Folder, compName As String, subj As String, _
                 saveFolder As String, saveFileName As String)

    Const ROOT_FOLDER As String = "C:\Users\rootname\OneDrive\Desktop\VBATesting\"

    Dim objItem As Object, objMailItem As Outlook.MailItem, dirFolderName As String
    Dim objAttachment As Outlook.Attachment

    For Each objItem In srcFolder.Items.Restrict(PFilter(compName, subj))
        If objItem.Class = Outlook.olMail Then 'Check Item Class

            Set objMailItem = objItem 'Set as Mail Item

            If ProcessThisMail(objMailItem) Then
                With objMailItem

                    dirFolderName = ROOT_FOLDER & saveFolder & _
                                    Format(objMailItem.ReceivedTime, "yyyy-mm") & "\"

                    EnsureSaveFolder dirFolderName

                    Debug.Print "Message:", objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject

                    For Each objAttachment In .Attachments
                        Debug.Print , "Attachment:", objAttachment.Filename

                        objAttachment.SaveAsFile dirFolderName & _
                              saveFileName & Format(objMailItem.ReceivedTime, "yyyy-mm-dd")
                    Next

                End With
            End If 'processing this one
        End If 'is a mail item
    Next objItem
End Sub

'return a filter for company and subject
Function PFilter(sCompany, sSubj)
    PFilter = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@" & sCompany & "%'" & _
              "AND ""urn:schemas:httpmail:subject"" LIKE '%" & sSubj & "%'"
End Function

'Abstract out the rules for when a mail is processed
Function ProcessThisMail(theMail As Outlook.MailItem) As Boolean
    Dim iBackdate As Long
    If theMail.Attachments.Count > 0 Then
        Select Case Weekday(Now)
            Case 7: iBackdate = 3 ' Saturday: add extra day
            Case 1, 2, 3: iBackdate = 4 ' Sunday through Tuesday: add extra 2 days
            Case Else: iBackdate = 2 ' Other days
        End Select
        If theMail.ReceivedTime > DateAdd("d", -iBackdate, Now) Then
            ProcessThisMail = True 'will by default return false unless this line is reached
        End If
    End If
End Function

'ensure a subfolder exists
Sub EnsureSaveFolder(sPath As String)
    With CreateObject("scripting.filesystemobject")
        If Not .FolderExists(sPath) Then
            .CreateFolder sPath
        End If
    End With
End Sub

【讨论】：

这太棒了蒂姆。将进行相应的调试和修改。在我挣扎的地方，我希望您不会介意我在这里发帖以寻求您或任何人的帮助。代码简短且更易于管理。非常感谢蒂姆
我在 VBA 中工作了 20 年以上，但我并不认为自己是“大师”。它只是随着时间的推移而建立起来......如果你还需要做一些其他事情，我会发布一个新问题（或回顾一些关于同一主题的现有问题）
我已经搜索过，我得到的是 FileToOpen = Application.GetOpenFilename(Filefilter:="Excel Files (*.xlsx), *.xlsx", Title:="Select Workbook to Import" ，多选：=真）。此代码需要用户输入（以便用户主动选择要打开的文件）。我的目标是自动化仅将保存在不同文件夹中的最后 9 个下载文件复制到一个 Excel 表中。像这样： If IsArray(FileToOpen) Then For FileCount = 1 To UBound(FileToOpen) 'as a array, shNewDat.Cells.Clear LastRow = shAll.Cells(Rows.Count, 1).End(xlUp).Row + 1 ...
所以最终的标准是下载的附件在各自的文件夹中将自己复制到一个新的工作表上，新工作表将是主文件。下一次下载（第二天 - （按照上面的约定标准排除周末））将自动填充主文件。这个可以吗？
可能是的，但这是一个单独的问题，并且在 cmets 中发布的代码不是很可读。请为此创建一个新问题，如果它满足您的需求，请将其标记为已回答。