Outlook 2010 VBA to save selected email to a folder other emails in that conversation have already been moved to

Question

I am attempting to code a way to automate filing of emails. I file all of my emails in a pretty detailed set of sub-folders in my inbox. I have MANY subfolders that help me organize my emails but this leads to a lot of extra time being spent in cleaning out my inbox (by filing emails to the relevant sub-folder). I would like to automate this so that I can select an email in my inbox and run the macro to display a list of folders that emails in the same conversation thread have already been filed in and allow me to select which one to save the selected email to. I have found several sample codes that are close but nothing that really does this action.

http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/ shows how to move messages to sub-folders when you know what sub-folder you want the email to go to. This doesn't work for my situation because I want the macro to give me a list of "recommended" folders.

I thought the below code may be a good place to start if I could figure out a way to loop through each "child" (not sure if that is the right word) of the conversation for the selected email and move the selected to the folder if the user selects "Yes" in the 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

I am having trouble putting together the loop that could make this work. Does anyone have any suggestions for how to use the above or any other options?

---

Edit

Not sure really how to show my next steps on this without "answering" my own question. This is my first question so I don't know all of the rules yet, if this is wrong please let me know so I can fix it. I'm not fully finished but I've gotten a lot closer with the help of the below answer. Below is my updated code:

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

I dropped this into a userform with a listbox. My intention is to allow only unique folder names to be added. Once that is accomplished I would like to add a button that can be clicked to file the selected email in the folder chosen from the listbox. Does anyone have any notes/good starting places on these next steps? I have been searching online for different ways to do this but I keep coming across long sub's and I have to imagine there is a more elegant solution. I'll update again if I find something that works. Thanks again for your help!

Answer 1

It looks like you are interested in the GetConversation method which returns a Conversation object that represents the conversation to which this item belongs.

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

Thanks for your hard work! I wanted the same functionality and expanded on your code to add a listbox to select a folder and only allow unique folder names to be added to the listbox. I also added code to move the emails after a folder is selected. The finished code is working in Outlook 2016 and hosted on GitHub since listbox files are stored as binaries and cannot be shown here.

GitHub: outlook-move-to-thread

To update listbox and not allow duplicates in 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

To update listbox and not allow duplicates in 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