作成したもの
- 選択メールを階層型で表示され、分岐箇所がわかりやすく
- 開くボタンを押すとそのメールが開く
- 件名が変わっても紐づく(完全でないと思う)
背景
-
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
参考記事と引用
以下のサイトは非常に助かりました。
お願い
- 引用する場合には本記事をリンクお願いします(>_<)
- ソースコードの動作は保証いたしかねます
- ソースコードの使用よって生じる問題について責任は負いかねます