【VBA】OutlookのメールデータをExcelに取得するマクロ

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 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

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