指定フォルダ内の.msgファイルからメール情報を取得

Private Enum clm
    To_ = 1
    CC
    BCC
    受信日時
    タイトル
    本文
    送信者
    送信者アドレス
    送信日時
    受信者名
End Enum

'*********************************
'* folderPath：フォルダのパス
Private Sub ExtractMsgContents(ByVal folderPath As String)
    Dim msgFileName As String
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim outputSheet As Worksheet
    Dim rowCounter As Integer

    ' 出力先のシートを作成
    Set outputSheet = Sheets.Add
    
    ' Outlookアプリケーションを作成
    Set outlookApp = CreateObject("Outlook.Application")

    ' 出力先シートの初期化
    outputSheet.Cells.Clear
    outputSheet.Cells(1, clm.To_).Value = "To"
    outputSheet.Cells(1, clm.CC).Value = "CC"
    outputSheet.Cells(1, clm.BCC).Value = "BCC"
    outputSheet.Cells(1, clm.受信日時).Value = "受信日時"
    outputSheet.Cells(1, clm.タイトル).Value = "タイトル"
    outputSheet.Cells(1, clm.本文).Value = "本文"
    outputSheet.Cells(1, clm.送信者).Value = "送信者"
    outputSheet.Cells(1, clm.送信者アドレス).Value = "送信者アドレス"
    outputSheet.Cells(1, clm.送信日時).Value = "送信日時"
    outputSheet.Cells(1, clm.受信者名).Value = "受信者名"
    rowCounter = 2

    ' フォルダ内の.msgファイルに対して処理
    msgFileName = Dir(folderPath & "*.msg")
    Do While msgFileName <> ""
        ' Outlookメールアイテムを開く
        Set outlookMail = outlookApp.GetNamespace("MAPI").OpenSharedItem(folderPath & msgFileName)
        
        ' メール情報を、セルに書込み
        With outlookMail
            outputSheet.Cells(rowCounter, clm.To_).Value = .To
            outputSheet.Cells(rowCounter, clm.CC).Value = .CC
            outputSheet.Cells(rowCounter, clm.BCC).Value = .BCC
            outputSheet.Cells(rowCounter, clm.受信日時).Value = .ReceivedTime
            outputSheet.Cells(rowCounter, clm.タイトル).Value = .Subject
            outputSheet.Cells(rowCounter, clm.本文).Value = .Body
            outputSheet.Cells(rowCounter, clm.送信者).Value = .SenderName
            outputSheet.Cells(rowCounter, clm.送信者アドレス).Value = .SenderEmailAddress
            outputSheet.Cells(rowCounter, clm.送信日時).Value = .SentOn
            outputSheet.Cells(rowCounter, clm.受信者名).Value = .ReceivedByName
        End With
        
        ' 行カウンタを増やす
        rowCounter = rowCounter + 1
        
        ' 次のファイルを処理
        msgFileName = Dir
    Loop

    ' 後処理
    Set outlookApp = Nothing
    Set outputSheet = Nothing
End Sub

Private Sub 使用例()
    ' メールの保管されているフォルダのパスを指定
    Call ExtractMsgContents("C:\TEMP\")
End Sub