便利ツール – Outlookで検索結果のメールのフォルダを調べる

Outlook上で検索を行い、検索結果として一覧されたメールアイテムが、どのフォルダに格納されているかが分からない。

＋プロジェクト①
　　＋やりとり
　　＋メモ
　　＋アクセス情報
＋プロジェクト②
　　＋やりとり
　　＋メモ
　　＋アクセス情報
＋プロジェクト③
　　＋やりとり
　　＋メモ
　　＋アクセス情報

Option Explicit

'
'   選択されているメールアイテムのパスを取得する。
'
Sub FindMailItemTree()

    Dim strAllPath                  As String
    Dim objSelect                   As Outlook.Selection
    Dim lngItem                     As Long
    
    '   パス一覧をクリアする。
    strAllPath = ""
    
    '   選択されているアイテムを取得する。
    Set objSelect = Outlook.Application.ActiveExplorer.Selection
    
    If objSelect.Count <= 0 Then
        Call MsgBox("メールアイテムを選択してください。")
        Exit Sub
    End If
    
    '   選択されているアイテムを走査する。
    For lngItem = 1 To objSelect.Count Step 1
    
        Dim strPath                     As String
        Dim objItem                     As Object
    
        '   パスをクリアする。
        strPath = ""
    
        '   アイテムを取得する。
        Set objItem = objSelect.Item(lngItem)
        
        '   パスを走査する。
        Do While True

            Dim strName As String

            '   アイテムの名前を取得する。
            Select Case UCase(TypeName(objItem))
            
            '   メールアイテム？
            Case UCase("MailItem")
                strName = "【" & objItem.Subject & "】"
            
            '   フォルダ？
            Case UCase("MAPIFolder")
                strName = objItem.Name
            
            '   上記以外
            '   終了する。
            Case Else
                Exit Do
            
            End Select

            '   パスに名前を追加する。
            If strPath <> "" Then
                strPath = "\" & strPath
            End If
            strPath = strName & strPath

            '   親アイテムを取得する。
            Set objItem = objItem.Parent

        Loop
    
        '   パス一覧に追加する。
        strAllPath = strAllPath & strPath & vbCrLf & vbCrLf
    
    Next lngItem
    
    '   パス一覧を表示する。
    Call MsgBox(strAllPath)
  
End Sub

プロジェクト①\やりとり\【メールの表題】

Call objItem.Display()