Outlook VBA 自动移动邮件或对话问题

我要完成的工作：

• 我突出显示我要归档的邮件

• For 循环在我突出显示的每个邮件项目上运行其余内容-因此，其余操作针对所选的每个单个对象完成

• 宏会在主题行中拉出“特定”文本，以决定将邮件移至哪个文件夹(这已经有效)

• 它创建(如果需要)，然后设置将要移动项目的文件夹。 (已经可以使用)

• 这是我的问题所在-我可以将其设置为可以处理每个单独的邮件项目，并且可以正常工作(对 50 封突出显示的邮件进行排序)，或者一次包含多个邮件的对话。我已经将其与任一调整一起使用。但是，我无法使其同时与 either/or 一起使用。

• 移至下一个突出显示的项目或对话。现在，“联合代码”适用于单个邮件项目，但是对话与先前的邮件仍然留在收件箱中。

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

Sub MoveToFiledAUTO2()
    On Error Resume Next

    Dim ns As Outlook.Namespace
    Dim moveToFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim Myvalue As String
    Dim myFolder As Outlook.folder
    Dim myNewFolder As Outlook.folder
    Set ns = Application.GetNamespace("MAPI")
    Dim vSplit As Variant
    Dim sWord As Variant
    Dim minisplit As Variant
    Dim objSelection As Outlook.Selection
    Dim IsMessage As Integer

    Set myFolder = ns.Folders("Current Projects").Folders("BU")
    Set objSelection = Outlook.Application.ActiveExplorer.Selection

    For Each objItem In objSelection
        If TypeOf objItem Is MailItem Then
            subby = objItem.Subject
            vSplit = Split(subby)
            For Each sWord In vSplit
                If Left$(sWord, 1) = "8" And Len(sWord) = 6 Then
                    Myvalue = Left$(sWord, 6)
                    Exit For
                ElseIf Left$(sWord, 2) = "#8" And Len(sWord) = 7 Then
                    Myvalue = Mid$(sWord, 2, 6)
                    Exit For
                ElseIf Left$(sWord, 4) = "BU#8" And Len(sWord) = 9 Then
                    Myvalue = Mid$(sWord, 4, 6)
                    Exit For
                ElseIf Left$(sWord, 3) = "U#8" And Len(sWord) = 8 Then
                    Myvalue = Mid$(sWord, 3, 6)
                    Exit For
                ElseIf Left$(sWord, 3) = "BU8" And Len(sWord) = 8 Then
                    Myvalue = Mid$(sWord, 3, 6)
                    Exit For
                ElseIf Left$(sWord, 1) = "8" And Len(sWord) = 7 Then
                    Myvalue = Left$(sWord, 6)
                    Exit For
                Else
                End If
            Next
            Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)
            IsMessage = 0
            Set myNewFolder = myFolder.Folders.Add(Myvalue)
            Set moveToFolder = ns.Folders("Current Projects").Folders("BU").Folders(Myvalue)
            If moveToFolder Is Nothing Then
                MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
            End If
            For Each Msg In ActiveExplorer.Selection
                If moveToFolder.DefaultItemType = olMailItem Then
                    If objItem.Class = olMail Then
                        objItem.UnRead = False
                        objItem.FlagStatus = olNoFlag
                        objItem.Move moveToFolder
                        objItem.Categories = ""
                        objItem.Save
                        IsMessage = 1
                    End If
                End If
            Next Msg
            If IsMessage = 0 Then
                For Each Header In Conversations
                   Set Items = Header.GetItems()
                   For i = 1 To Items.Count
                       Items(i).UnRead = False
                       Items(i).Move moveToFolder
                       Items(i).FlagStatus = olNoFlag
                       Items(i).Categories = ""
                       Items(i).Save
                   Next i
                Next Header
            End If

        End If
    Next

    Set objItem = Nothing
    Set moveToFolder = Nothing
    Set ns = Nothing
    Set myFolder = Nothing
End Sub