【VBA】Outlookからメールデータを取得する

Excel VBAでOutlookのメールデータを抽出するプログラムを作った時に地味に躓いたり、歯痒いところに手が届かないことが多かったので備忘半分でプログラムを残しています

調べれば調べるほど微調整箇所が多いのでちょくちょく更新するつもりなので最終更新日を要確認です

基本方針
参照設定
全体プログラム
プロシージャ別の説明
あとがき

基本方針

今回はOutlookに設定している全アカウントの受信/送信メール全て取得できるようにしています

VBAはバージョンで動かなくなる可能性があるのでこのプログラムを作成・利用している私の環境はコチラ

OS	Windows 10 Home 64bit
Outlookのバージョン	Microsoft® Outlook® for Microsoft 365 MSO (バージョン 2403 ビルド 16.0.17425.20176) 32 ビット

参照設定

プログラムを作り始める前にまずは参照設定から

外部ライブラリ読み込んだ方がプログラムを作りやすいので今回はOutlook用の「Microsoft Outlook 16.0 Object Library」を有効にしてあげる

全体プログラム

説明はいいからとにかくマクロが欲しいって方へ

全部コピペすれば使えるはず

Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" _
    Alias "SHCreateDirectoryExA" _
    (ByVal hwnd As LongPtr, _
     ByVal pszPath As String, _
     ByVal psa As LongPtr) As Long
'---後で編集しやすいように列番号は列挙型で宣言しておく
Enum lngCol
    Account = 1
    FolderName
    SenderEmailAddress
    MailTO
    MailCC
    MailBCC
    ReceivedTime
    MailSubject
    MailBody
    AttachmentsCount
End Enum
Public ws As Worksheet
Sub GetOutlookMail()
Dim oApp As New Outlook.Application
Dim oNS As Outlook.Namespace
Dim oFld As Outlook.Folder

'---画面更新処理を止めておく
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'---出力するシートの設定
Set ws = CreateSheet
ws.Select
ws.Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)).EntireRow.Delete

'---MAPIをセット
Set oNS = oApp.GetNamespace("MAPI")
For Each oFld In oNS.Folders
    '---アカウント名を継承させながらフォルダを再帰処理しながら検索する
    Call SearchFolder(oFld.Name, "", oFld)
Next
Set oNS = Nothing

Set ws = Nothing
'---画面更新処理を復旧させる
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

'---終了メッセージ
MsgBox "更新完了しました"
End Sub
Private Function SearchFolder(Account As String, FolderPath As String, TargetFolder As Outlook.Folder)
'==============================
'メールフォルダを再帰処理で検索する
'==============================
Dim oFld As Outlook.Folder

'---同期の問題と同期の失敗フォルダを除外する処置
If TargetFolder.Name Like "同期の*" Then
    Exit Function
End If

'---フォルダタイプがメールだったら中のメール情報を取得する
If TargetFolder.DefaultItemType = olMailItem Then
    Call GetMailData(Account, FolderPath, TargetFolder)
End If

'---フォルダ情報をパンくず形式で継承しつつ再帰処理させる
For Each oFld In TargetFolder.Folders
    Call SearchFolder(Account, FolderPath & IIf(Len(FolderPath) > 0, " > ", "") & oFld.Name, oFld)
Next
End Function
Private Function GetMailData(Account As String, TargetFolderName As String, TargetFolder As Outlook.Folder)
'==============================
'対象フォルダからメール情報を取得してエクセルに反映させる
'==============================
Dim oItems As Outlook.Items
Dim oItem As Outlook.MailItem
Dim oAtt As Outlook.Attachment
Dim i As Long
Dim lngRow As Long
Dim strFilter
Dim savePath As String

With ws
    .Select
    Set oItems = TargetFolder.Items
    '---ステータスバーに取得フォルダ等を表示する
    Application.StatusBar = "「" & Account & "」の「" & TargetFolderName & "」から" & oItems.Count & "件のデータ取得中・・・"
    '---取得したメールを反映させる
    For i = 1 To oItems.Count
        '---データがメールタイプじゃない可能性があるので確認して取得する
        If oItems(i).Class = olMail Then
            '---入力行（最下行の次）を取得する
            lngRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            '---メールアイテムを変数にセットする
            Set oItem = oItems(i)
            .Cells(lngRow, lngCol.Account).Value = Account
            .Cells(lngRow, lngCol.FolderName).Value = TargetFolderName
            .Cells(lngRow, lngCol.SenderEmailAddress).Value = oItem.SenderEmailAddress
            .Cells(lngRow, lngCol.MailTO).Value = SplitMailStr(oItem.To, oItem.Recipients)
            .Cells(lngRow, lngCol.MailCC).Value = SplitMailStr(oItem.CC, oItem.Recipients)
            .Cells(lngRow, lngCol.MailBCC).Value = SplitMailStr(oItem.BCC, oItem.Recipients)
            .Cells(lngRow, lngCol.ReceivedTime).Value = oItem.ReceivedTime
            With .Cells(lngRow, lngCol.MailSubject)
                .NumberFormatLocal = "@" '---先頭文字が=(イコール)などで始まるとエラーになるから表示形式を文字列にする
                .Value = oItem.Subject
                .WrapText = False '---折り返し表示すると動作が重くなるので解除する
                .NumberFormatLocal = "G/標準" '---表示形式を標準に戻す
            End With
            With .Cells(lngRow, lngCol.MailBody)
                .NumberFormatLocal = "@" '---本文が=(イコール)で始まるとエラーになるから表示形式を文字列にする
                .Value = oItem.Body
                .WrapText = False '---折り返し表示すると動作が重くなるので解除する
                .NumberFormatLocal = "G/標準" '---表示形式を標準に戻す
            End With
            '---添付ファイルを取得する
            .Cells(lngRow, lngCol.AttachmentsCount).Value = oItem.Attachments.Count
            For Each oAtt In oItem.Attachments
                '---受信日時をベースにフルパスフォルダ名を決める
                savePath = ThisWorkbook.Path & "\att\" & Format(oItem.ReceivedTime, "yyyymmdd_hhmm")
                '---多重階層フォルダを作成する
                rc = SHCreateDirectoryEx(0&, savePath, 0&)
                '---ここで実際にフォルダを作成する
                oAtt.SaveAsFile savePath & "\" & oAtt.Filename
            Next
            '---内外全てにグレー罫線を引く
            With .Range(Cells(lngRow, lngCol.Account), Cells(lngRow, lngCol.AttachmentsCount)).Borders()
                .LineStyle = xlContinuous
                .Weight = xlThin
                .Color = RGB(128, 128, 128)
            End With
            Set oItem = Nothing
        End If
    Next
    '---ステータスバーをリセットする
    Application.StatusBar = False
End With
End Function
Private Function SplitMailStr(MailStr As String, RecipientsData As Recipients)
'==============================
'宛先が複数ある場合は;（セミコロン）区切りになっているので一度分解してChangeAliasで変換した後に結合する
'==============================
Dim i As Long, MailArray As Variant

MailArray = Split(MailStr, ";")
For i = LBound(MailArray) To UBound(MailArray)
    MailArray(i) = ChangeAlias(MailArray(i), RecipientsData)
Next
SplitMailStr = Join(MailArray, ";")
End Function
Private Function ChangeAlias(Alias As Variant, RecipientsData As Recipients)
'==============================
'宛先情報がエイリアスになっている場合があるからメアドに変換する
'==============================
Dim RecipientData As Recipient
'---@が含まれているならメアドなのでそのまま
If Alias Like "*@*" Then
    ChangeAlias = Alias
    Exit Function
End If

'---表示名が受信者情報と一致していたらアドレスに変換する
For Each RecipientData In RecipientsData
    If Trim(RecipientData.Name) = Trim(Alias) Then
        ChangeAlias = RecipientData.Address
        Exit Function
    End If
Next

'---変換できなかったらそのまま返す ※ココに到達することはないはず
ChangeAlias = Alias
End Function
Private Function CreateSheet(Optional SheetName = "OUTPUT") As Worksheet
Set CreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
With CreateSheet
    '---シート名を変えるけど重複する可能性があるのでエラー無視する
    On Error Resume Next
    .Name = SheetName
    On Error GoTo 0
    '---ヘッダー部の設定
    .Cells(1, lngCol.Account).Value = "Account"
    .Cells(1, lngCol.FolderName).Value = "FolderName"
    .Cells(1, lngCol.SenderEmailAddress).Value = "SenderEmailAddress"
    .Cells(1, lngCol.MailTO).Value = "MailTO"
    .Cells(1, lngCol.MailCC).Value = "MailCC"
    .Cells(1, lngCol.MailBCC).Value = "MailBCC"
    .Cells(1, lngCol.ReceivedTime).Value = "ReceivedTime"
    .Cells(1, lngCol.MailSubject).Value = "MailSubject"
    .Cells(1, lngCol.MailBody).Value = "MailBody"
    .Cells(1, lngCol.AttachmentsCount).Value = "AttachmentsCount"
    With .Range(Cells(1, lngCol.Account), Cells(1, lngCol.AttachmentsCount))
        .EntireColumn.ColumnWidth = 19.88
        .Interior.Color = RGB(191, 191, 191)
        With .Borders()
            .LineStyle = xlContinuous
            .Weight = xlThin
            .Color = RGB(128, 128, 128)
        End With
    End With
End With
End Function

プロシージャ別の説明

ここからはプロシージャ別に分解して少し詳しく説明します

共通部分

Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" _
    Alias "SHCreateDirectoryExA" _
    (ByVal hwnd As LongPtr, _
     ByVal pszPath As String, _
     ByVal psa As LongPtr) As Long
'---後で編集しやすいように列番号は列挙型で宣言しておく
Enum lngCol
    Account = 1
    FolderName
    SenderEmailAddress
    MailTO
    MailCC
    MailBCC
    ReceivedTime
    MailSubject
    MailBody
    AttachmentsCount
End Enum
Public ws As Worksheet

“SHCreateDirectoryEx”は多重階層でフォルダを作成する時のWindows API
添付ファイルを保存する時に使うので宣言しておく

lngColは列挙型で列番号を宣言しておくとプログラムが作りやすい気がする個人的なお作法

wsはプロシージャを跨いで使うのでPublicで宣言しておく

GetOutlookMail

Sub GetOutlookMail()
Dim oApp As New Outlook.Application
Dim oNS As Outlook.Namespace
Dim oFld As Outlook.Folder

'---画面更新処理を止めておく
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'---出力するシートの設定
Set ws = CreateSheet
ws.Select
ws.Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)).EntireRow.Delete

'---MAPIをセット
Set oNS = oApp.GetNamespace("MAPI")
For Each oFld In oNS.Folders
    '---アカウント名を継承させながらフォルダを再帰処理しながら検索する
    Call SearchFolder(oFld.Name, "", oFld)
Next
Set oNS = Nothing

Set ws = Nothing
'---画面更新処理を復旧させる
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

'---終了メッセージ
MsgBox "更新完了しました"
End Sub

メインプロシージャ

これ自体にはたいして説明する部分はないですが画面更新を止めるのは個人的お作法

SearchFolder

Private Function SearchFolder(Account As String, FolderPath As String, TargetFolder As Outlook.Folder)
'==============================
'メールフォルダを再帰処理で検索する
'==============================
Dim oFld As Outlook.Folder

'---同期の問題と同期の失敗フォルダを除外する処置
If TargetFolder.Name Like "同期の*" Then
    Exit Function
End If

'---フォルダタイプがメールだったら中のメール情報を取得する
If TargetFolder.DefaultItemType = olMailItem Then
    Call GetMailData(Account, FolderPath, TargetFolder)
End If

'---フォルダ情報をパンくず形式で継承しつつ再帰処理させる
For Each oFld In TargetFolder.Folders
    Call SearchFolder(Account, FolderPath & IIf(Len(FolderPath) > 0, " > ", "") & oFld.Name, oFld)
Next
End Function

Outlookがアカウントを起点としたフォルダ構成になっているので再帰処理をして順番にフォルダを巡りながらそのフォルダからメール情報を取得するようにしています

フォルダの中には連絡先などメールフォルダではないものがあるのでメールを取得する対象かどうか”DefaultItemType”で判定しています

GetMailData

Private Function GetMailData(Account As String, TargetFolderName As String, TargetFolder As Outlook.Folder)
'==============================
'対象フォルダからメール情報を取得してエクセルに反映させる
'==============================
Dim oItems As Outlook.Items
Dim oItem As Outlook.MailItem
Dim oAtt As Outlook.Attachment
Dim i As Long
Dim lngRow As Long
Dim rc As Long
Dim strFilter
Dim savePath As String

With ws
    .Select
    Set oItems = TargetFolder.Items
    '---ステータスバーに取得フォルダ等を表示する
    Application.StatusBar = "「" & Account & "」の「" & TargetFolderName & "」から" & oItems.Count & "件のデータ取得中・・・"
    '---取得したメールを反映させる
    For i = 1 To oItems.Count
        '---データがメールタイプじゃない可能性があるので確認して取得する
        If oItems(i).Class = olMail Then
            '---入力行（最下行の次）を取得する
            lngRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            '---メールアイテムを変数にセットする
            Set oItem = oItems(i)
            .Cells(lngRow, lngCol.Account).Value = Account
            .Cells(lngRow, lngCol.FolderName).Value = TargetFolderName
            .Cells(lngRow, lngCol.SenderEmailAddress).Value = oItem.SenderEmailAddress
            .Cells(lngRow, lngCol.MailTO).Value = SplitMailStr(oItem.To, oItem.Recipients)
            .Cells(lngRow, lngCol.MailCC).Value = SplitMailStr(oItem.CC, oItem.Recipients)
            .Cells(lngRow, lngCol.MailBCC).Value = SplitMailStr(oItem.BCC, oItem.Recipients)
            .Cells(lngRow, lngCol.ReceivedTime).Value = oItem.ReceivedTime
            With .Cells(lngRow, lngCol.MailSubject)
                .NumberFormatLocal = "@" '---先頭文字が=(イコール)などで始まるとエラーになるから表示形式を文字列にする
                .Value = oItem.Subject
                .WrapText = False '---折り返し表示すると動作が重くなるので解除する
                .NumberFormatLocal = "G/標準" '---表示形式を標準に戻す
            End With
            With .Cells(lngRow, lngCol.MailBody)
                .NumberFormatLocal = "@" '---本文が=(イコール)で始まるとエラーになるから表示形式を文字列にする
                .Value = oItem.Body
                .WrapText = False '---折り返し表示すると動作が重くなるので解除する
                .NumberFormatLocal = "G/標準" '---表示形式を標準に戻す
            End With
            '---添付ファイルを取得する
            .Cells(lngRow, lngCol.AttachmentsCount).Value = oItem.Attachments.Count
            For Each oAtt In oItem.Attachments
                '---受信日時をベースにフルパスフォルダ名を決める
                savePath = ThisWorkbook.Path & "\att\" & Format(oItem.ReceivedTime, "yyyymmdd_hhmm")
                '---多重階層フォルダを作成する
                rc = SHCreateDirectoryEx(0&, savePath, 0&)
                '---ここで実際にフォルダを作成する
                oAtt.SaveAsFile savePath & "\" & oAtt.Filename
            Next
            '---内外全てにグレー罫線を引く
            With .Range(Cells(lngRow, lngCol.Account), Cells(lngRow, lngCol.AttachmentsCount)).Borders()
                .LineStyle = xlContinuous
                .Weight = xlThin
                .Color = RGB(128, 128, 128)
            End With
            Set oItem = Nothing
        End If
    Next
    '---ステータスバーをリセットする
    Application.StatusBar = False
End With
End Function

これがズバリメール情報の取得部分でポイントが何点か・・・

For Nextでループしているとメールタイプじゃないアイテムも検知してしまい、型エラーの原因になるのでClassでメールかどうか判断しています

“TO、CC、BCC”はそのままだと連作先のエイリアスが反映してしまい、メアドがわからなくなってしまうのでサブプロシージャで変換するようにします

件名と本文はExcelに反映させた時、標準書式の状態で”=”や”@”が先頭だと数式判定になってエラーになるので反映前に文字列化→反映→標準書式へ戻す手順で反映させています

添付ファイルを取得する時にメールと紐づきがわかるようにファイル受信日時フォルダを作成してそこに保存するようにしていますが判断しにくいなら適当に編集してもらえれば

SplitMailStr

Private Function SplitMailStr(MailStr As String, RecipientsData As Recipients)
'==============================
'宛先が複数ある場合は;（セミコロン）区切りになっているので一度分解してChangeAliasで変換した後に結合する
'==============================
Dim i As Long, MailArray As Variant

MailArray = Split(MailStr, ";")
For i = LBound(MailArray) To UBound(MailArray)
    MailArray(i) = ChangeAlias(MailArray(i), RecipientsData)
Next
SplitMailStr = Join(MailArray, ";")
End Function

次の”ChangeAlias”ためのサブプロシージャ

TOやCCに複数名設定されているとセミコロン（;）をデリミタで結合された状態になっていてエイリアス→メアドの変換がうまくできないので分解してそれぞれにChangeAliasする

ChangeAlias

Private Function ChangeAlias(Alias As Variant, RecipientsData As Recipients)
'==============================
'宛先情報がエイリアスになっている場合があるからメアドに変換する
'==============================
Dim RecipientData As Recipient
'---@が含まれているならメアドなのでそのまま
If Alias Like "*@*" Then
    ChangeAlias = Alias
    Exit Function
End If

'---表示名が受信者情報と一致していたらアドレスに変換する
For Each RecipientData In RecipientsData
    If Trim(RecipientData.Name) = Trim(Alias) Then
        ChangeAlias = RecipientData.Address
        Exit Function
    End If
Next

'---変換できなかったらそのまま返す ※ココに到達することはないはず
ChangeAlias = Alias
End Function

“GetMailData”にも書いた通りエイリアスをメアドに変える処理

Recipientsの中にエイリアスとメアドのセット情報があるので変換元になるエイリアスと一致したらメアドを返してあげる

CreateSheet

Private Function CreateSheet(Optional SheetName = "OUTPUT") As Worksheet
Set CreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
With CreateSheet
    '---シート名を変えるけど重複する可能性があるのでエラー無視する
    On Error Resume Next
    .Name = SheetName
    On Error GoTo 0
    '---ヘッダー部の設定
    .Cells(1, lngCol.Account).Value = "Account"
    .Cells(1, lngCol.FolderName).Value = "FolderName"
    .Cells(1, lngCol.SenderEmailAddress).Value = "SenderEmailAddress"
    .Cells(1, lngCol.MailTO).Value = "MailTO"
    .Cells(1, lngCol.MailCC).Value = "MailCC"
    .Cells(1, lngCol.MailBCC).Value = "MailBCC"
    .Cells(1, lngCol.ReceivedTime).Value = "ReceivedTime"
    .Cells(1, lngCol.MailSubject).Value = "MailSubject"
    .Cells(1, lngCol.MailBody).Value = "MailBody"
    .Cells(1, lngCol.AttachmentsCount).Value = "AttachmentsCount"
    With .Range(Cells(1, lngCol.Account), Cells(1, lngCol.AttachmentsCount))
        .EntireColumn.ColumnWidth = 19.88
        .Interior.Color = RGB(191, 191, 191)
        With .Borders()
            .LineStyle = xlContinuous
            .Weight = xlThin
            .Color = RGB(128, 128, 128)
        End With
    End With
End With
End Function

出力先になるシートをセットする

ヘッダーの文字に書式と罫線を設定していますが内容はお好みで