VBA 函数或宏将选定的消息移动到对话文件夹

Question

我将所有 Outlook 消息组织为对话。我正在寻找一种功能，可以将当前选定的消息从收件箱移动到其各自的文件夹中。

例如，如果我有一个名为“每周状态报告”的电子邮件对话，该对话已归档到“工程”文件夹中，并且我在收件箱中收到回复，我想运行宏并将回复移动到“工程”文件夹。

我在 Microsoft Office Professional Plus 2010 中使用 Outlook。

我最初尝试解决这个问题，但我想：

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 ' Mail Item
    Dim folder As Outlook.MAPIFolder ' Current Item's Folder
    Dim conversation As Outlook.conversation ' Get the conversation
    ' Dim ItemsTable As Outlook.table ' Conversation table object
    Dim mailItem As Object
    Dim mailparent As Object

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

    ' On Error GoTo MsgErr
    ' // Must Selected Item.
    Set selectedItem = Application.ActiveExplorer.Selection.item(1)

    ' // If Item = a 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 ' Items in the conversation.
                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

    'Convert folderpath to array
    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

    'Return the TestFolder
    Set GetFolder = TestFolder
    Exit Function

GetFolder_Error:
    Set GetFolder = Nothing
Exit Function

End Function

Answer 1

这是一个类似的脚本，可能会有帮助。

我的用例有点不同 - 我手动选择自定义视图中的项目，然后从工具栏按钮运行脚本。（我发现对话没有得到正确跟踪，而且有时对话会分散到不同的项目中。）

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

  ' move items
  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

  ' get folder
  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  ' Non-existant DefaultFolders cause errors
  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