如何在对话中移动所有消息？

Question

我需要知道如何一次移动对话中的所有消息.

我的宏目前正在阅读

Sub Archive()
    Set ArchiveFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archive")
    For Each Msg In ActiveExplorer.Selection
        Msg.UnRead = False
        Msg.Move ArchiveFolder
    Next Msg
End Sub

但这只会移动最新消息......并且只有当对话完全崩溃时!在扩展对话时我无法存档.

Answer 1

Paul-Jan让我走上了正确的道路,所以我给了他答案.这是我真正糟糕的VBA版本(我缺少一些类型转换,检查).但它确实适用于折叠和扩展的邮件对话.

Sub ArchiveConversation()
    Set ArchiveFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archive")
    Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)
    For Each Header In Conversations
        Set Items = Header.GetItems()
        For i = 1 To Items.Count
            Items(i).UnRead = False
            Items(i).Move ArchiveFolder
        Next i
    Next Header
End Sub

Answer 2

安东尼的回答几乎对我有用。但它不适用于消息和对话。这是我的修改：

Sub Archive()
    Set ArchiveFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("Archive")

    Dim IsMessage As Integer
    IsMessage = 0

    For Each Msg In ActiveExplorer.Selection
        Msg.Move ArchiveFolder
        IsMessage = 1
    Next Msg

    If IsMessage = 0 Then
        Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)
        For Each Header In Conversations
            Set Items = Header.GetItems()
            For i = 1 To Items.Count
                Items(i).UnRead = False
                Items(i).Move ArchiveFolder
            Next i
        Next Header
    End If

End Sub