VBA функция или макрос для перемещения выбранного(ых) сообщения(й) в папку беседы

Я организую все свои сообщения в Outlook в виде бесед. Я ищу функцию для перемещения текущего выбранного сообщения(ий) из входящих в соответствующие папки.

Например, если у меня есть письмо с темой “Еженедельный отчет о статусе”, которое было помещено в папку “Инженерия”, и я получаю ответ во входящих, я хотел бы запустить макрос и переместить ответ в папку “Инженерия”.

Я использую Outlook в Microsoft Office Professional Plus 2010.

Моя первая попытка решения проблемы работает в какой-то степени, но я хотел бы:

1. Добавить функциональность для объектов, не являющихся MailItem;
2. Упорядочить цикл For Each, сначала проверяя, указаны ли все корневые элементы для беседы в одной и той же таблице. Если нет, я хотел бы предложить пользователю выбрать нужную папку через диалоговое окно.

Вот моя текущая попытка:

Sub moveMailToConversationFolder()

    Dim olNs As NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim selectedItem As Object
    Dim item As Outlook.mailItem ' Почтовый элемент
    Dim folder As Outlook.MAPIFolder ' Папка текущего элемента
    Dim conversation As Outlook.conversation ' Получить беседу
    ' Dim ItemsTable As Outlook.table ' Объект таблицы беседы
    Dim mailItem As Object
    Dim mailparent As Object

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    ' On Error GoTo MsgErr
    ' // Должен быть выбран элемент.
    Set selectedItem = Application.ActiveExplorer.Selection.item(1)

    ' // Если элемент = MailItem.
    If TypeOf selectedItem Is Outlook.mailItem Then
        Set item = selectedItem
        Set conversation = item.GetConversation

        If Not IsNull(conversation) Then
            ' Set ItemsTable = conversation.GetTable

            ' MsgBox conversation.GetRootItems.Count

            For Each mailItem In conversation.GetRootItems ' Элементы в беседе.
                If TypeOf mailItem Is Outlook.mailItem Then
                    Set folder = mailItem.Parent
                    item.move GetFolder(folder.FolderPath)
                End If
            Next
        End If
    End If

End Sub

Function GetFolder(ByVal FolderPath As String) As Outlook.folder

    Dim TestFolder As Outlook.folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolder_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If

    'Преобразовать путь к папке в массив
    FoldersArray = Split(FolderPath, "\")
    Set TestFolder = Application.Session.Folders.item(FoldersArray(0))
    If Not TestFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = TestFolder.Folders
            Set TestFolder = SubFolders.item(FoldersArray(i))
            If TestFolder Is Nothing Then
                Set GetFolder = Nothing
            End If
        Next
    End If

    'Вернуть TestFolder
    Set GetFolder = TestFolder
    Exit Function

GetFolder_Error:
    Set GetFolder = Nothing
Exit Function

End Function

Вот похожий скрипт, который может помочь.

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

Option Explicit
Option Base 0

Public Sub MoveToFirstFolder()
  Dim oNamespace As Outlook.NameSpace, oSelection As Outlook.Selection
  Dim oFolder As Outlook.MAPIFolder
  Dim oItem As Object, i As Integer

  Set oNamespace = Application.GetNamespace("MAPI")

  Set oSelection = oNamespace.Application.ActiveExplorer.Selection
  If oSelection.Count < 2 Then Exit Sub

  Set oFolder = getFirstNonDefaultFolder(oSelection)
  If oFolder Is Nothing Then Exit Sub

  ' перемещение элементов
  For i = 1 To oSelection.Count
    Set oItem = oSelection.Item(i)
    If Not oItem.Parent = oFolder Then
      oSelection.Item(i).Move oFolder
    End If
  Next i
End Sub

Private Function getFirstNonDefaultFolder(oSelection As Outlook.Selection) As Outlook.Folder
  Dim oItem As Object
  Dim oFolder As Outlook.Folder
  Dim i As Integer

  ' получить папку
  For i = 1 To oSelection.Count
    Set oFolder = oSelection.Item(i).Parent
    Debug.Print ">" & oFolder.FullFolderPath
    If Not isDefaultFolder(oFolder) Then
      Set getFirstNonDefaultFolder = oFolder
      Exit Function
    End If
  Next i
End Function

Private Function isDefaultFolder(oFolder As Outlook.Folder) As Boolean
  Dim oNamespace As Outlook.NameSpace
  Dim defaultFolders, fldrNum

  isDefaultFolder = False

  defaultFolders = Array( _
    olFolderInbox, olFolderSentMail, _
    olFolderDrafts, _
    olFolderDeletedItems, olFolderJunk, _
    olFolderOutbox, _
    olFolderCalendar, _
    olFolderContacts, olFolderSuggestedContacts, _
    olFolderNotes, _
    olFolderTasks, olFolderToDo, _
    olFolderJournal, _
    olFolderConflicts, olFolderLocalFailures, olFolderServerFailures, olFolderSyncIssues, _
    olFolderManagedEmail, olPublicFoldersAllPublicFolders _
  )

  Set oNamespace = Application.GetNamespace("MAPI")

  On Error Resume Next  ' Не существующие стандартные папки вызывают ошибки
  For Each fldrNum In defaultFolders
    If oFolder = oNamespace.GetDefaultFolder(fldrNum) Then
      If Err.Number Then
        Err.Clear
      Else
        isDefaultFolder = True
        Exit Function
      End If
    End If
  Next fldrNum
End Function