|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
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 |
【VBA】【Excel】CDO.Messageを使ったメール解析プログラム例
Excel【VBA】
コメント