作成したもの

選択メールを階層型で表示され、分岐箇所がわかりやすく
開くボタンを押すとそのメールが開く
件名が変わっても紐づく(完全でないと思う）

背景

1つのメールに対して複数人が返信してきてよくわからなくなる時があったので可視化してみたいと思った
件名変えられたときにスレッドを紐づけたいと思った

ソースコード(一部)

TreeNodeクラスにデータを詰めるところまで本記事では扱います。
必要なコードのみ抜き出して記載しているので漏れがあるかもです。
Outlook VBAは情報が少なくて難しい

データ構造クラス

TreeNode.cls

Private m_Parent As treeNode
Private m_Children As Collection ' TreeNodeClass
Public Data As Variant

Private Sub Class_Initialize()
    Set m_Children = New Collection
End Sub

'親ノードのセット
Public Property Set Parent(ByVal value As treeNode)
    Set m_Parent = value
End Property

'親ノードの取得
Public Property Get Parent() As treeNode
    Set Parent = m_Parent
End Property

' 子ノードのコレクションの取得
Public Property Get Children() As Collection
    Set Children = m_Children
End Property

'''' メソッド
''' ####################################################################################################################

' 子ノードを追加するメソッド
Public Sub AddChild(ByVal childNode As treeNode)
    Set childNode.Parent = Me
    Call m_Children.Add(childNode)
End Sub

Public Function GetAllChildrenCount() As Long
    Dim totalCount As Long
    totalCount = 0
    
    ' 再帰的に全子ノードのカウントを行う
    Dim childNode As treeNode
    For Each childNode In m_Children
        totalCount = totalCount + 1 ' 自分自身をカウント
        totalCount = totalCount + childNode.GetAllChildrenCount ' 子ノードのカウントを加算
    Next
    
    GetAllChildrenCount = totalCount
End Function

TreeNodeを構築するメイン処理

MailConversationTree.bas


'検索対象のフォルダ 文字列型でカンマ区切りにする
'受信トレイ、送信済み、削除済みフォルダはデフォルトで検索されるので追加しないでください
Private Const SEARCH_FOLDER_PATH_LIST = "YourFolderPathList"

Private MailTreeNode As treeNode

''' Main関数
Public Sub FeatureMailConversationTree()
    Dim currentItem As mailItem
    Set currentItem = mail.GetCurrentMailItem()
    
    If currentItem Is Nothing Then
        Call MsgBox("メールを選択してください")
    End If
    ' 会話を取得
    Dim conversationItem As conversation
    Set conversationItem = currentItem.GetConversation()
    Dim convesationRootItems As SimpleItems
    Set convesationRootItems = conversationItem.GetRootItems()
    
    Set MailTreeNode = New treeNode
    Set MailTreeNode.Data = convesationRootItems.item(1)
    
    ' MailTreeNodeを構築するためのサブプロシージャ
    Call ProcessConversationRootItems(GetMailItemOnly(convesationRootItems), MailTreeNode)
    
    Call ConversationTreeForm.Show(False) 'モードレスじゃないとメールが開けない
    Call ConversationTreeForm.DrawTree(MailTreeNode)
    
    
End Sub


Private Sub ProcessConversationRootItems(ByVal rootMailItems As Collection, ByRef parentNode As treeNode)
    Dim argsItem As mailItem
    Dim argsTreeNode As treeNode
    
    ' 既定の初期値を設定
    Set argsItem = rootMailItems.item(1)
    Set argsTreeNode = parentNode
    
    Select Case rootMailItems.count
        Case 1
            ' アイテムが1つの場合、何も変更せずにそのまま進む
        Case 2
            ' アイテムが2つの場合、ConversationIndexを比較して処理を進める
            If rootMailItems.item(1).ConversationIndex = rootMailItems.item(2).ConversationIndex Then
                Dim nextNode As treeNode
                Set nextNode = New treeNode
                Call parentNode.AddChild(nextNode)
                Set nextNode.Data = rootMailItems.item(2)
                
                Set argsItem = rootMailItems.item(2)
                Set argsTreeNode = nextNode
            End If
            
        Case Else
            ' 想定外のケースの場合、デバッグ出力して終了
            Call Err.Raise(1111, , "Mailアイテムの数が異常です。処理を終了します")
            Exit Sub
    End Select
    
    Call BuildConversationTree(argsItem, argsTreeNode, argsItem.ConversationID)
End Sub



Private Function BuildConversationTree(ByVal rootMailItem As Outlook.mailItem, ByRef parentTreeNode As treeNode, ByVal originalConversationId As String) As treeNode
    Dim conversation As Outlook.conversation
    
    ' 会話を取得して子アイテムを処理
    Set conversation = rootMailItem.GetConversation
    If conversation Is Nothing Then
        Exit Function
    End If
    
    Dim childItems As SimpleItems
    Set childItems = conversation.GetChildren(rootMailItem)

    ' ConversationIndexでグルーピングする
    Dim conversationIndexGroups As Object  'ディクショナリ
    Set conversationIndexGroups = mail.GroupMailItemsByConversationIndex(mail.GetMailItemOnly(childItems))
    
    Call ProcessConversationIndexGroups(conversationIndexGroups, parentTreeNode, originalConversationId)
    
    ' ConversationID(件名)が変わった返信がないか調べ、あれば再起処理
    Dim replyMailItems As Collection
    Set replyMailItems = GetReplyMailItemsInFolders(GetInternetMessageId(rootMailItem), GetSearchFolders())
    
    ' 今と同じ会話Idのメールアイテムを削除し、新しいコレクションを取得
    Set replyMailItems = FilterMailItemsByDifferentConversationId(replyMailItems, originalConversationId)
    
    ' ConversationIDでグルーピングされたメールアイテムを処理
    Dim conversationIdGroups As Object  'ディクショナリ
    Set conversationIdGroups = GroupMailItemsByConversationId(replyMailItems)
    
    Dim conversationIdKey As Variant
    For Each conversationIdKey In conversationIdGroups.keys
        Dim groupedMailItems As Collection
        Set groupedMailItems = conversationIdGroups(conversationIdKey)
        
        Dim conversationIndexGroupsOther As Object  'ディクショナリ
        Set conversationIndexGroupsOther = GroupMailItemsByConversationIndex(groupedMailItems)
        
        Call ProcessConversationIndexGroups(conversationIndexGroupsOther, parentTreeNode, originalConversationId)
    Next
    
    Set BuildConversationTree = parentTreeNode
End Function

''' conversationIndexでグループ化されたディクショナリに対して処理
Private Sub ProcessConversationIndexGroups(ByVal conversationIndexGroups As Object, ByRef parentTreeNode As treeNode, ByVal originalConversationId As String)
    Dim conversationIndexKey As Variant
    For Each conversationIndexKey In conversationIndexGroups.keys
        Dim groupedMailItems As Collection
        Set groupedMailItems = conversationIndexGroups(conversationIndexKey)
        Set groupedMailItems = SortMailItemsByCreationTime(groupedMailItems) ' 昇順Sort
        
        Dim treeNode As treeNode
        Dim mailItem As mailItem
        Dim firstTreeNode As treeNode
        
        Set firstTreeNode = ProcessGroupedMailItems(groupedMailItems, treeNode, mailItem)
        
        If Not firstTreeNode Is Nothing Then
            Call BuildConversationTree(mailItem, treeNode, originalConversationId)
            Call parentTreeNode.AddChild(firstTreeNode)
        End If
    Next
End Sub

''' conversationIndexでグループ済みのコレクションに対してTreeNodeを構築。自分も宛先に含めて送信している場合に対応するためのもの。ByRefになっているので注意
'''
Private Function ProcessGroupedMailItems(ByVal groupedMailItems As Collection, ByRef processedTreeNode As treeNode, ByRef processedMailItem As mailItem) As treeNode
    Dim rootTreeNode As treeNode
    
    If groupedMailItems.count = 1 Or groupedMailItems.count = 2 Then
        Set rootTreeNode = New treeNode
        Set rootTreeNode.Data = groupedMailItems(1)
    Else
        ' エラーハンドリング（必要に応じて実装）
        Call Err.Raise(1111, , "Mailアイテムの数が異常です。処理を終了します")
        Set ProcessGroupedMailItems = Nothing
        Exit Function
    End If
    
    Select Case groupedMailItems.count
        Case 1
            Set processedTreeNode = rootTreeNode
            Set processedMailItem = groupedMailItems(1)
        Case 2
            '自分も宛先に含めて送信している場合
            Dim replyTreeNode As treeNode
            Set replyTreeNode = New treeNode
            Set replyTreeNode.Data = groupedMailItems(2)
            Call rootTreeNode.AddChild(replyTreeNode)
            
            Set processedTreeNode = replyTreeNode
            Set processedMailItem = groupedMailItems(2)
    End Select
    
    Set ProcessGroupedMailItems = rootTreeNode
End Function

''' 指定されたConversationIDと異なるメールアイテムだけを保持する新しいCollectionを返します。
Private Function FilterMailItemsByDifferentConversationId(ByVal mailItems As Collection, ByVal conversationIdToRemove As String) As Collection
    Dim filteredMailItems As New Collection
    Dim i As Long
    
    For i = 1 To mailItems.count
        If mailItems(i).ConversationID <> conversationIdToRemove Then
            filteredMailItems.Add mailItems(i)
        End If
    Next
    
    Set FilterMailItemsByDifferentConversationId = filteredMailItems
End Function

''' 検索対象のフォルダを取得します
Private Function GetSearchFolders() As Collection
    Set GetSearchFolders = Nothing
    
    Dim serachFolders As Collection
    Set serachFolders = FolderFunc.GetDefaultFolderByMail()
    Dim f As Variant
    For Each f In Split(SEARCH_FOLDER_PATH_LIST)
        Dim folderPath As String
        folderPath = f
        folderPath = TrimWhitespaceAndNewlines(folderPath)
    
        Call serachFolders.Add(FolderFunc.GetFolder(folderPath))
    Next
    Set GetSearchFolders = serachFolders
End Function

Helper関数

Mail.bas

'返信元のID
Const PR_IN_REPLY_TO_ID = "http://schemas.microsoft.com/mapi/proptag/0x1042001e"
'インタネットメッセージID
Const PR_INTERNET_MESSAGE_ID = "http://schemas.microsoft.com/mapi/proptag/0x1035001e"
'会話ID
Const PR_CONVERSATION_ID = "http://schemas.microsoft.com/mapi/proptag/0x30130102"

Const PR_PARENT_ENTRY_ID = "http://schemas.microsoft.com/mapi/proptag/0x0e090102"

''' 引数に渡されたobjectがMailItemかを判断します。
''' item: mail / appointment ・・・
''' return: true=maiItem, false=mailItem以外
Public Function IsMailItem(ByVal item As Object) As Boolean
    IsMailItem = False
    If TypeOf item Is mailItem Then
        IsMailItem = True
    End If
End Function

''' itemsからMailItemだけ抜き出して返します。
''' item: SimpleItems
''' return: 抜き出したMailItemコレクション
Public Function GetMailItemOnly(ByVal items As SimpleItems) As Collection
    Dim item As Variant
    Dim mailItems As New Collection
    
    ' SimpleItems内をループ
    For Each item In items
        If IsMailItem(item) Then
            mailItems.Add item
        End If
    Next item
    
    ' Collectionを返す
    Set GetMailItemOnly = mailItems
End Function

''' mailItemCollectionをConvesationIndexでグループ化します。
''' return: グループ化したディクショナリ
Public Function GroupMailItemsByConversationIndex(ByVal mailItemsCollection As Collection) As Object
    Dim dict As Object
    Set dict = GetDictionaryInstance()

    Dim mailItem As mailItem
    Dim convIndex As String
    
    ' コレクション内の各MailItemを処理
    For Each mailItem In mailItemsCollection
        convIndex = mailItem.ConversationIndex
        
        ' ディクショナリにConversationIndexをキーとして追加
        If dict.Exists(convIndex) Then
            ' 既に存在するキーの場合は、そのコレクションに追加

            Call dict(convIndex).Add(mailItem)

        Else
            ' 新しいキーの場合は、新たにコレクションを作成し、追加
            Dim newCollection As Collection
            Set newCollection = New Collection
            Call newCollection.Add(mailItem)
            Call dict.Add(convIndex, newCollection)
        End If
    Next mailItem
   
    ' ディクショナリを返す
    Set GroupMailItemsByConversationIndex = dict
End Function

''' mailItemCollectionをConvesationIdでグループ化します。
''' return: グループ化したディクショナリ
Public Function GroupMailItemsByConversationId(ByVal mailItemsCollection As Collection) As Object
    Dim dict As Object
    Set dict = GetDictionaryInstance()

    Dim mailItem As mailItem
    Dim key As String
    
    ' コレクション内の各MailItemを処理
    For Each mailItem In mailItemsCollection
        key = mailItem.ConversationID
        
        ' ディクショナリにConversationIndexをキーとして追加
        If dict.Exists(key) Then
            ' 既に存在するキーの場合は、そのコレクションに追加

            Call dict(key).Add(mailItem)

        Else
            ' 新しいキーの場合は、新たにコレクションを作成し、追加
            Dim newCollection As Collection
            Set newCollection = New Collection
            Call newCollection.Add(mailItem)
            Call dict.Add(key, newCollection)
        End If
    Next mailItem
   
    ' ディクショナリを返す
    Set GroupMailItemsByConversationId = dict
End Function

''' 現在のmailItemを取得します。
''' return: 取得できたmailItem, 取得できんかった場合はNothingになります。
Public Function GetCurrentMailItem() As mailItem
    Set GetCurrentMailItem = Nothing
    
    Dim item As Object
    Set item = GetCurrentItem()
    
    If IsMailItem(item) Then
        Set GetCurrentMailItem = item
    End If
End Function

''' creationtTimeで昇順にソート
''' return: creationtTimeを昇順
Public Function SortMailItemsByCreationTime(mailItems As Collection) As Collection
    Dim sortedItems As New Collection
    Dim i As Long, j As Long
    Dim tempMailItem As mailItem
    Dim tempIndex As Long

    ' 挿入ソートアルゴリズムを使用して、mailItemsをCreationTimeで昇順にソート
    For i = 1 To mailItems.count
        Set tempMailItem = mailItems(i)
        
        If sortedItems.count = 0 Then
            sortedItems.Add tempMailItem
        Else
            For j = 1 To sortedItems.count
                If tempMailItem.CreationTime < sortedItems(j).CreationTime Then
                    sortedItems.Add tempMailItem, , j
                    Exit For
                End If
            Next j
            
            ' 新しいアイテムが最後までソートされたリストに追加されなかった場合、最後に追加
            If j > sortedItems.count Then
                sortedItems.Add tempMailItem
            End If
        End If
    Next i
    
    Set SortMailItemsByCreationTime = sortedItems
End Function

''' InternetMessageIdをIn-Reply-Toに持つMailItemコレクションを返します
''' id: InternetMessageId
''' targetFolder: 検索するフォルダ
''' return: MailItemコレクション
Public Function GetReplyMailItems(ByVal id As String, ByVal targetFolder As Outlook.folder) As Collection
    Dim filterString As String
    Dim findItems As items
    Dim result As New Collection
    Dim item As Variant
    
    filterString = "@SQL=""" & PR_IN_REPLY_TO_ID & """ = '" & id & "'"
    Set findItems = targetFolder.items.Restrict(filterString)
    
    For Each item In findItems
        Call result.Add(item)
    Next

    Set GetReplyMailItems = result
End Function

''' InternetMessageIdをIn-Reply-Toに持つMailItemを複数のフォルダから探し見つかったMailItemコレクションを返します
''' id: InternetMessageId
''' targetFolder: 検索するフォルダコレクション
''' return: MailItemコレクション
Public Function GetReplyMailItemsInFolders(ByVal id As String, ByVal targetFolders As Collection) As Collection

    Dim replyMailItems As Collection
    Set replyMailItems = New Collection
    
    Dim targetFolder
    For Each targetFolder In targetFolders
        Dim findReplyItems As Collection
        Set findReplyItems = GetReplyMailItems(id, targetFolder)
        
        Dim findReplyItem
        For Each findReplyItem In findReplyItems
            Call replyMailItems.Add(findReplyItem)
        Next
    Next
    
    Set GetReplyMailItemsInFolders = replyMailItems
End Function


''' 引数に渡されたMailItemからインターネットメッセージIDを取得します。
''' item: mailItem
''' return: 取得できたインターネットメッセージID
Public Function GetInternetMessageId(ByVal item As mailItem) As String
    GetInternetMessageId = item.PropertyAccessor.GetProperty(PR_INTERNET_MESSAGE_ID)
End Function

''' 引数に渡されたMailItemから返信元のIDを取得します。
''' item: mailItem
''' return: 取得できた返信元のID
Public Function GetInReplyToId(ByVal item As mailItem) As String
    GetInReplyToId = item.PropertyAccessor.GetProperty(PR_IN_REPLY_TO_ID)
End Function

''' 引数に渡されたMailItemから会話IDをPrpertyAccessorを使用して取得します。
''' item: mailItem
''' return: 取得できた会話ID
Public Function GetConversationIdBySchema(ByVal item As mailItem) As String
    With item.PropertyAccessor
        GetConversationId = .BinaryToString(.GetProperty(PR_CONVERSATION_ID))
    End With
End Function

FolderFunc.bas

''' デフォルトでメールで使用するフォルダを取得します。
''' return: Folderコレクション
Public Function GetDefaultFolderByMail() As Collection
    Dim folderList As New Collection
    Dim ns As NameSpace
    Set ns = Application.GetNamespace("MAPI")
    
    Call folderList.Add(ns.GetDefaultFolder(olFolderInbox)) '受信トレイ
    Call folderList.Add(ns.GetDefaultFolder(olFolderSentMail)) '送信済み
    Call folderList.Add(ns.GetDefaultFolder(olFolderDeletedItems)) '削除済み
    
    Set GetDefaultFolderByMail = folderList
End Function

''' デフォルトでメールで使用するフォルダを取得します。
''' folderPath: 取得するフォルダパス　例："\\Mailbox - mailAddress\Inbox\Customers"
''' return: Folderコレクション
Public 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
     
    Set GetFolder = TestFolder
    Exit Function
 
GetFolder_Error:
    Set GetFolder = Nothing
    Exit Function
End Function

Public Function GetCurrentItem() As Object
    Set GetCurrentItem = Nothing

    Dim olApp As Outlook.Application
    Set olApp = Application
    
    On Error Resume Next

    Select Case TypeName(olApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = olApp.ActiveExplorer.Selection.item(1)
        Case "Inspector"
            Set GetCurrentItem = olApp.ActiveInspector.currentItem
    End Select
    

    Set olApp = Nothing
End Function

Public Function GetDictionaryInstance() As Object
    Set GetDictionaryInstance = CreateObject("Scripting.Dictionary")
End Function

参考記事と引用

以下のサイトは非常に助かりました。

お願い

引用する場合には本記事をリンクお願いします(>_<)
ソースコードの動作は保証いたしかねます
ソースコードの使用よって生じる問題について責任は負いかねます