VBA：根据文件夹名称将电子邮件归档到网络存档，跳过某些条目

问：

有一些代码是我从一堆答案中拼凑出来的，这些代码主要做我想要的：从选定的 Outlook 文件夹中获取电子邮件，找到合适的位置将其放在我公司的主驱动器上并将其保存在那里，然后将电子邮件移动到存档文件夹。

今天，我尝试添加一个循环函数，让宏同时在多个文件夹上运行，并在此过程中导致某些东西中断。

该过程现在无法正确存档某些电子邮件，将它们保留在项目目录中，以便在再次运行宏时重新归档。它以前可能一直在这样做，但我没有注意到。该宏似乎也跳过了所选 outlook 文件夹的某些子文件夹，我不知道为什么。

Public Sub FileSelectedFolder()

    Dim nNameSpace As Object 'Outlook.Namespace
    Dim mFolderSelected As Object 'Outlook.MAPIFolder
     
    Set nNameSpace = GetNamespace("MAPI")

    Set mFolderSelected = nNameSpace.PickFolder

    ProcessFolder mFolderSelected

End Sub


Private Sub ProcessFolder(objParent As Object)

    Dim objFolder As Object 'Outlook.MAPIFolder
    Dim objMail As Object
    Dim strName As String
     
    'Runs the filing macro on every subfolder of the selected folder.
    If (objParent.Folders.Count > 0) Then
        For Each objFolder In objParent.Folders
            SaveWREmailstoMPF objFolder
        Next objFolder
    End If

End Sub


Sub SaveWREmailstoMPF(FolderName As Outlook.MAPIFolder)


    Dim ns As Outlook.NameSpace
    Dim folArchiveFolder As Outlook.MAPIFolder
    Dim strArray() As String, strWR As String, strRegion As String, strMPFBaseDir As String, strCorrespondenceDir As String, strMPFFullDir As String
    Dim strMPFGetDir As String, strPathExists As String, OpenLinkAddress As String, Retval As String, strCategory As String
    Dim objMailObject As Object
               
    strMPFBaseDir = "\\CompanyName\Projects\"              'Sets the basic directory parameters for saving to the project folder that are used for all projects
    strCorrespondenceDir = "\Correspondence"
    
    Set ns = Application.GetNamespace("MAPI")                         'Sets the namespace
    'Set FolderName = Application.ActiveExplorer.CurrentFolder           'Gets the currently selected folder in Outlook CURRENTLY TESTING LOOPING SO THIS IS COMMENTED OUT
    
    
    '-----------------------------------------------------------------
    'This section parses the folder name in Outlook, and determines the subdirectory to save the file to
    
    'Checks to see if the folder name is for a Work request, and stops the macro if it isn't
    If Left(FolderName, 2) <> "WR" Then
                 
        MsgBox "Inappropriate Folder selected - Not a Work Request folder", vbCritical
          
        Exit Sub
        
    Else
        
        'Splits the folder name to return the WR number, Region Code, and Address
        strArray = Split(FolderName, " - ")
        
    End If
    
    strWR = strArray(0)
    
    Debug.Print strArray(0)
    Debug.Print strArray(1)
    Debug.Print strArray(2)
                
    'Region:
    'This turns the abbreviation into the string for the MPF location and stores it for later use:
    Select Case strArray(1)
        
        Case "FN"
            strRegion = "Far_North"
            Debug.Print strRegion
            
        Case "N"
            strRegion = "North"
            'Debug.Print strRegion
            
        Case "C"
            strRegion = "Central"
            'Debug.Print strRegion
            
        Case "S"
            strRegion = "South"
            'Debug.Print strRegion
            
        Case "W"
            strRegion = "West"
            'Debug.Print strRegion
            
        Case "FS"
            strRegion = "Far_South"
            'Debug.Print strRegion
            
        Case Else
            MsgBox "Region code is not valid", vbCritical
            
    End Select
          
    'Directory:
    strMPFGetDir = strMPFBaseDir & "\" & strRegion & "\" & strWR & "*"          'Combines the parsed strings to get the wildcard location for the directory
        strPathExists = Dir(strMPFGetDir, vbDirectory)                             ' This returns subdirectory resulting from wildcard search, which has to be inserted into the actual destination folder link
                    
            If strPathExists = "" Then
                Retval = MsgBox("Cannot find Folder " & Chr(13) & strMPFGetDir & "." & Chr(13) & "File has NOT saved.", vbCritical, "Master Drive Directory")
                                      
                Exit Sub
                                      
            Else
                    
                Debug.Print PathExists
                    
                strMPFFullDir = strMPFBaseDir & "\" & strRegion & "\" & PathExists & strCorrespondenceDir
                        
                Debug.Print strMPFFullDir
                    
                'The following counts the number of emails in the Correspondence Directory:
                
                    Dim strIsMsg As String
                    Dim intEmailCount As Integer
                                        
                    strIsMsg = Dir(strMPFFullDir & "\" & "*.msg")
                    
                    Do While strIsMsg <> ""
                        intEmailCount = intEmailCount + 1
                        strIsMsg = Dir
                    Loop
                
                'At the end of this process, intEmailCount is the number of .msg files saved in the correspondence directory, and 1 can be added to it and then appended to the filename.
                'Use intEmailCount + 1. Do intEmailCount + 1 after each saved .msg
                    
                    intEmailCount = intEmailCount + 1 'the number for the email is added.
                                
            End If
            
            '-----------------------------------------------------------------
            'The following creates a filename for each object in the selected Outlook folder, then calls the Save Function to save the .msg
                   
            Dim strFileName As String
            Dim objItem As Object
                                    
            For Each objItem In FolderName.Items
            
                If objItem.Class = 43 Then 'Checks that the item is an Outlook Mail Item
            
                    If objItem.Sender Like "*company.com" Then    'If an email is something that I've sent, this appellation:
                        strFileName = intEmailCount & Chr(46) & Chr(32) & Format(objItem.SentOn, "yyyymmdd") & Chr(32) & _
                                Format(objItem.SentOn, "HH.MM") & Chr(32) & objItem.SenderName & " - " & objItem.Subject
                                
                    Else            'If an email has been received, then this appellation:
                        strFileName = intEmailCount & Chr(46) & Chr(32) & Format(objItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                                Format(objItem.ReceivedTime, "HH.MM") & Chr(32) & objItem.SenderName & " - " & objItem.Subject
                
                    End If
                    
                    'This replaces inappropriate characters in the filename string
                    strFileName = Replace(strFileName, Chr(58) & Chr(41), "")
                    strFileName = Replace(strFileName, Chr(58) & Chr(40), "")
                    strFileName = Replace(strFileName, Chr(34), "-")
                    strFileName = Replace(strFileName, Chr(42), "-")
                    strFileName = Replace(strFileName, Chr(47), "-")
                    strFileName = Replace(strFileName, Chr(58), "-")
                    strFileName = Replace(strFileName, Chr(60), "-")
                    strFileName = Replace(strFileName, Chr(62), "-")
                    strFileName = Replace(strFileName, Chr(63), "-")
                    strFileName = Replace(strFileName, Chr(124), "-")
                    
                    
                    'Saves the file with in the MPF directory with the updated filename, as an outlook message, provided it hasn't already been archived
                    strCategory = objItem.Categories
                    
                    If Not strCategory = "Archived" Then
                    
                        objItem.SaveAs strMPFFullDir & "\" & strFileName & ".msg", olMSG
                    
                    End If
                    
                    'Increases the Email Count to append numbers to the filenames sequentially
                    intEmailCount = intEmailCount + 1
       
                End If
                
            Next objItem
            
            '-----------------------------------------------------------------
            'The following then archives all the saved messages in the WR folder into the Archive subfolder so that they're not filed again
                
                       
            Dim olItems As Outlook.Items
            Dim olMailItem As Outlook.MailItem
            
            Dim i As Long
                         
            Set FolderName = Application.ActiveExplorer.CurrentFolder
            
            Set folArchiveFolder = FolderName.Folders("Archive")
            
            Set olItems = FolderName.Items
            
            Set olMailItem = olItems.GetFirst()
                                             
            olItems.Sort Property:="ReceivedTime", Descending:=True
                                                       
                For i = olItems.Count To 1 Step -1
                
                    Set olMailItem = olItems.GetFirst()
                    
                    Set olMailItem = olItems(i)
                    
                    strCategory = olMailItem.Categories
                    
                    If Not strCategory = "Archived" Then
                    
                        olMailItem.Categories = "Archived"
                        olMailItem.Move folArchiveFolder
                    
                    End If
                    
                Next i
                
lbl_Exit:
    Set olItems = Nothing
    Set FolderName = Nothing
    Set folArchiveFolder = Nothing
    Set olMailItem = Nothing
    Set folArchiveFolder = Nothing
    Set olMailItem = Nothing
    
    Exit Sub
        
End Sub

我在 VBA 方面不是很有经验，并且一直在尝试让这个宏作为一种学习体验。

这个网站上有来自其他几个项目的零碎代码 - 如果我应该提到我从哪里得到东西，不确定使用其他人代码的礼仪，我深表歉意。

我尝试过多次单步执行代码，有时它似乎开始运行整个事情，而不是让我单步执行它。

我希望这个宏可以自动获取所选Outlook文件夹的子文件夹中的所有电子邮件，按照发送/接收日期的顺序将它们保存到正确的网络目录中，然后将它们存档在Outlook中，这样它们就不会再次归档，因为公司希望每封电子邮件都以数字命名， 并按粗略的时间顺序排列。

作为奖励，我希望看到宏也只将最终电子邮件保存在线程链中，而不是每条单独的消息，但会接受我能得到的东西。任何反馈将不胜感激。

另外，现在我已经做了一些工作，我可以看到我可能应该拆分流程，以便更容易理解事情。