【VBA】【Excel】CDO.Messageを使ったメール解析プログラム例

Sub メール解析sample()
    '参照設定　Microsoft CDO for Windows 2000 Library
    Dim CDOMsg As CDO.Message
        
    Dim Ws As Worksheet
    Dim RowIndex As Long, ColmunIndex As Long
    
    Dim FileName As String
    
    Set Ws = ActiveSheet
    Set CDOMsg = GetMessage(FileName)
    
    FileName = "C:\test.eml"
    
    RowIndex = 1
    ColmunIndex = 1
    Ws.Cells(RowIndex, ColmunIndex) = FileCount
    Ws.Cells(RowIndex, ColmunIndex + 1) = CDOMsg.Subject
    Ws.Cells(RowIndex, ColmunIndex + 2) = CDOMsg.From
    Ws.Cells(RowIndex, ColmunIndex + 3) = CDOMsg.To
    Ws.Cells(RowIndex, ColmunIndex + 4) = CDOMsg.CC
    Ws.Cells(RowIndex, ColmunIndex + 5) = CDOMsg.BCC
    Ws.Cells(RowIndex, ColmunIndex + 6) = CDOMsg.SentOn
    Ws.Cells(RowIndex, ColmunIndex + 7) = CDOMsg.ReceivedTime
    Ws.Cells(RowIndex, ColmunIndex + 8) = CDOMsg.Attachments.Count
    
    If CDOMsg.Attachments.Count <> 0 Then
        Dim Attachment As IBodyPart
        Dim i As Long
        For i = 1 To CDOMsg.Attachments.Count
            Set Attachment = CDOMsg.Attachments(i)
            If Ws.Cells(RowIndex, ColmunIndex + 9) = "" Then
                Ws.Cells(RowIndex, ColmunIndex + 9) = Attachment.FileName
            Else
                Ws.Cells(RowIndex, ColmunIndex + 9) = Ws.Cells(RowIndex, ColmunIndex + 9) & "," & Attachment.FileName
            End If
        Next i
    End If
    

End Sub



'参考URL
'https://docs.microsoft.com/en-us/previous-versions/exchange-server/exchange-10/ms526988(v=exchg.10)
Private Function GetMessage(ByVal FilePath As String) As CDO.Message
    '参照設定　Microsoft CDO for Windows 2000 Library
    '参照設定　Microsoft ActiveX Data Objects x.x Library

    
    'emlファイルからMessage取得
    Dim ADOStream As ADODB.Stream
    Dim CDOMsg As CDO.Message
    Set ADOStream = New ADODB.Stream
    Set CDOMsg = New CDO.Message
    
    ADOStream.Open
    ADOStream.LoadFromFile FilePath
    CDOMsg.DataSource.OpenObject ADOStream, "_Stream"
    ADOStream.Close
    Set GetMessage = CDOMsg

    'ADOStreamはここまで
    Set ADOStream = Nothing
    
End Function