Outlook 2010 VBA 將選定的電子郵件保存到該對話中的其他電子郵件已移動到的文件夾中

Question

我正在嘗試編寫一種自動歸檔電子郵件的方法。 我將所有電子郵件歸檔到收件箱中一組非常詳細的子文件夾中。 我有許多子文件夾可以幫助我整理電子郵件，但這會導致我花費大量額外時間清理收件箱（通過將電子郵件歸檔到相關子文件夾）。 我想自動執行此操作，以便我可以在收件箱中選擇一封電子郵件並運行宏以顯示同一對話線程中的電子郵件已歸檔的文件夾列表，並允許我選擇保存所選電子郵件的文件夾到。 我發現了幾個很接近但沒有真正執行此操作的示例代碼。

http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/顯示了當您知道您想要電子郵件的子文件夾時如何將消息移動到子文件夾要去。 這對我的情況不起作用，因為我希望宏給我一個“推薦”文件夾列表。

我認為下面的代碼可能是一個很好的起點，如果我能找到一種方法來循環遍歷所選電子郵件的對話的每個“子”（不確定這是否是正確的詞）並將所選電子郵件移動到文件夾如果用戶在 MsgBox 中選擇“是”。

Public Sub GetItemsFolderPath()
  Dim obj As Object
  Dim F As Outlook.MAPIFolder
  Dim convItemFolders As Outlook.MAPIFolder
  Dim msg$
  Dim rootitemcount

  Set obj = Application.ActiveWindow
  If TypeOf obj Is Outlook.Inspector Then
    Set obj = obj.CurrentItem
  Else
    Set obj = obj.Selection(1)
  End If

  Set F = obj.Parent
  msg = " The path is: " & F.FolderPath & rootitemcount & vbCrLf
  msg = msg & "Switch to the folder?"
  If MsgBox(msg, vbYesNo) = vbYes Then
    Set Application.ActiveExplorer.CurrentFolder = F
  End If
End Sub

我在整理可能使這項工作的循環時遇到了麻煩。 有沒有人對如何使用上述或任何其他選項有任何建議？

---

編輯

不確定如何在不“回答”我自己的問題的情況下展示我的下一步。 這是我的第一個問題，所以我還不知道所有規則，如果這是錯誤的，請告訴我，以便我可以解決它。 我還沒有完全完成，但在以下答案的幫助下，我已經走得更近了。 下面是我更新的代碼：

Public Sub GetConverstationInformation()

    Dim host As Outlook.Application
    Set host = ThisOutlookSession.Application

    ' Check for Outlook 2010
    If Left(host.Version, 2) = "14" Then
        Dim selectedItem As Object
        Dim theMailItem As Outlook.mailItem

        ' Get the user's currently selected item.
        Set selectedItem = host.ActiveExplorer.Selection.item(1)

        ' Check to see if the item is a MailItem.
        If TypeOf selectedItem Is Outlook.mailItem Then
            Set theMailItem = selectedItem
            ' Check to see that the item's current folder
            ' has conversations enabled.
            Dim parentFolder As Outlook.folder
            Dim parentStore As Outlook.store
            Set parentFolder = theMailItem.Parent
            Set parentStore = parentFolder.store
            If parentStore.IsConversationEnabled Then
                ' Try and get the conversation.
                Dim theConversation As Outlook.conversation
                Set theConversation = theMailItem.GetConversation
                If Not IsNull(theConversation) Then
                    ' Outlook provides a table object
                    ' the contains all of the items in the
                    ' conversation.
                    Dim itemsTable As Outlook.table
                    Set itemsTable = theConversation.GetTable

                    ' Get the Root Items
                    ' Enumerate the list of items
                    ' only writing out data for MailItems.
                    ' A conversation can contain other items
                    ' like MeetingItems.
                    ' Then use a helper method and recursion
                    ' to walk all the items in the conversation.
                    Dim group As Outlook.simpleItems
                    Set group = theConversation.GetRootItems
                    Dim obj As Object
                    Dim fld As Outlook.folder
                    Dim mi As Outlook.mailItem
                    'Dim i As Long
                    For Each obj In group
                        If TypeOf obj Is Outlook.mailItem Then
                        Set mi = obj
                        Set fld = mi.Parent

                   'For i = 1 To group.Count
                        Me.ListBox1.AddItem fld.Name

                'mi.Sender & _
                    '" sent the message '" & mi.Subject & _
                    '"' which is in '" &
                     '& "'."
                 'Next i
                        End If
                            GetConversationDetails mi, theConversation
                   Next obj
                Else
                    MsgBox "The currently selected item is not a part of a conversation."
                End If
            Else
                MsgBox "The currently selected item is not in a folder with conversations enabled."
            End If
        Else
            MsgBox "The currently selected item is not a mail item."
        End If
    Else
        MsgBox "This code only works with Outlook 2010."
    End If
End Sub

Private Sub GetConversationDetails(anItem As Object, theConversation As Outlook.conversation)
    Dim group As Outlook.simpleItems
    Set group = theConversation.GetChildren(anItem)

    If group.Count > 0 Then
        Dim obj As Object
        Dim fld As Outlook.folder
        Dim mi As Outlook.mailItem
         'Dim i As Long
        'For i = 1 To group.Count(obj)
        For Each obj In group
            If TypeOf obj Is Outlook.mailItem Then

                Set mi = obj
                Set fld = mi.Parent
                'Dim counter

                Me.ListBox1.AddItem fld.Name

                'mi.Sender & _
                    '" sent the message '" & mi.Subject & _
                    '"' which is in '" &
                     '& "'."

            End If
            GetConversationDetails mi, theConversation
        Next obj
        'Next i
    End If
End Sub



Private Sub UserForm_Initialize()
GetConverstationInformation
End Sub

我把它放到一個帶有列表框的用戶表單中。 我的意圖是只允許添加唯一的文件夾名稱。 完成后，我想添加一個按鈕，可以單擊該按鈕將選定的電子郵件歸檔到從列表框中選擇的文件夾中。 有沒有人對這些后續步驟有任何注意事項/好的起點？ 我一直在網上搜索不同的方法來做到這一點，但我不斷遇到長潛艇，我不得不想象有一個更優雅的解決方案。 如果我找到有用的東西，我會再次更新。 再次感謝你的幫助！

Answer 1

看起來您對GetConversation方法感興趣，該方法返回一個Conversation對象，該對象表示該項目所屬的對話。

Private Sub DemoConversation()
  Dim selectedItem As Object = Application.ActiveExplorer().Selection(1)
  ' For this example, you will work only with 
  'MailItem. Other item types such as
  'MeetingItem and PostItem can participate 
  'in Conversation.
  If TypeOf selectedItem Is Outlook.MailItem Then
    ' Cast selectedItem to MailItem.
    Dim mailItem As Outlook.MailItem = TryCast(selectedItem, Outlook.MailItem)


    ' Determine store of mailItem.
    Dim folder As Outlook.Folder = TryCast(mailItem.Parent, Outlook.Folder)
    Dim store As Outlook.Store = folder.Store
    If store.IsConversationEnabled = True Then
        ' Obtain a Conversation object.
        Dim conv As Outlook.Conversation = mailItem.GetConversation()
        ' Check for null Conversation.
        If conv IsNot Nothing Then
            ' Obtain Table that contains rows 
            ' for each item in Conversation.
            Dim table As Outlook.Table = conv.GetTable()
            Debug.WriteLine("Conversation Items Count: " + table.GetRowCount().ToString())
            Debug.WriteLine("Conversation Items from Table:")
            While Not table.EndOfTable
                Dim nextRow As Outlook.Row = table.GetNextRow()
                Debug.WriteLine(nextRow("Subject") + " Modified: " + nextRow("LastModificationTime"))
            End While
            Debug.WriteLine("Conversation Items from Root:")
            ' Obtain root items and enumerate Conversation.
            Dim simpleItems As Outlook.SimpleItems = conv.GetRootItems()
            For Each item As Object In simpleItems
                ' In this example, enumerate only MailItem type.
                ' Other types such as PostItem or MeetingItem
                ' can appear in Conversation.
                If TypeOf item Is Outlook.MailItem Then
                    Dim mail As Outlook.MailItem = TryCast(item, Outlook.MailItem)
                    Dim inFolder As Outlook.Folder = TryCast(mail.Parent, Outlook.Folder)
                    Dim msg As String = mail.Subject + " in folder " + inFolder.Name
                    Debug.WriteLine(msg)
                End If
                ' Call EnumerateConversation 
                ' to access child nodes of root items.
                EnumerateConversation(item, conv)
            Next
        End If
    End If
   End If
 End Sub

Private Sub EnumerateConversation(item As Object, conversation As Outlook.Conversation)
  Dim items As Outlook.SimpleItems = conversation.GetChildren(item)
  If items.Count > 0 Then
    For Each myItem As Object In items
        ' In this example, enumerate only MailItem type.
        ' Other types such as PostItem or MeetingItem
        ' can appear in Conversation.
        If TypeOf myItem Is Outlook.MailItem Then
            Dim mailItem As Outlook.MailItem = TryCast(myItem, Outlook.MailItem)
            Dim inFolder As Outlook.Folder = TryCast(mailItem.Parent, Outlook.Folder)
            Dim msg As String = mailItem.Subject + " in folder " + inFolder.Name
            Debug.WriteLine(msg)
        End If
        ' Continue recursion.
        EnumerateConversation(myItem, conversation)
    Next
  End If
End Sub

Answer 2

感謝您的辛勤工作！ 我想要相同的功能並擴展您的代碼以添加一個列表框來選擇一個文件夾，並且只允許將唯一的文件夾名稱添加到列表框中。 我還添加了在選擇文件夾后移動電子郵件的代碼。 完成的代碼在 Outlook 2016 中運行並托管在 GitHub 上，因為列表框文件存儲為二進制文件，無法在此處顯示。

GitHub: Outlook 移動到線程

要更新列表框並且不允許在GetConversationInformation()重復，

For Each obj In group
    If TypeOf obj Is Outlook.mailItem Then
        ' If ROOT item is an email, add it to ListBox1
        Set mi = obj
        Set fld = mi.Parent

        ' Don't include duplicate folders
        IsInListBox = False
        For i = 0 To Me.ListBox1.ListCount - 1
            If Me.ListBox1.Column(0, i) = fld.FolderPath Then
                IsInListBox = True
            End If
        Next

        If (InStr(fld.FolderPath, "Inbox") = 0) And _
            (InStr(fld.FolderPath, "Sent Items") = 0) And _
            (IsInListBox = False) Then
            Me.ListBox1.AddItem fld.FolderPath
        End If
    End If
        GetConversationDetails mi, theConversation
Next obj

要更新列表框並且不允許在GetConversationDetails()重復，

' Don't include generic folders
If (InStr(fld.FolderPath, "Inbox") = 0) And _
    (InStr(fld.FolderPath, "Sent Items") = 0) Then

    ' Don't include duplicate folders
    IsInListBox = False
    For i = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Column(0, i) = fld.FolderPath Then
            IsInListBox = True
        End If
    Next

    ' Add to ListBox1
    If IsInListBox = False Then
        Me.ListBox1.AddItem fld.FolderPath
    End If

End If