Outlook VBA Auto переместить почтовое сообщение или проблемы с разговором

Question

То, что я пытаюсь выполнить:

1. Я выделяю сообщения, которые я хочу отправить
2. Цикл For запускает остальное для каждого элемента почты, который я выделяю, - поэтомуотдых делается для каждого выбранного отдельного объекта
3. Макрос извлекает определенный текст в строке темы, чтобы решить, в какую папку переместить почту (Это уже работает)
4. Создает (если необходимо), затем устанавливает папку, в которую элементы будут перемещены.(работает уже)

5. Вот в чем моя проблема - я могу настроить его так, чтобы он работал на каждом отдельном элементе почты, и он отлично работает (сортирует 50 выделенных писем),или один разговор с несколькими предметами.Я получил его для работы с любой настройкой.Однако я не могу заставить его работать с обоими, или / или.

6. Переход к следующему элементу или выделенному разговору.Сейчас «объединенный код» работает для отдельных почтовых отправлений, но разговоры остаются с предыдущими письмами, которые все еще находятся в папке «Входящие».

Вот мой код:

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