Outlookで受信したメールを自動でExcelに一覧化するVBAマクロ

Option Explicit

'-----------------------------------------
' このマクロは、Outlookから指定のフォルダ内のメールおよび開封通知(ReportItem)を取得し、
' Excelシートに一覧として蓄積します。
'
' 【主な特徴】
' - ユーザーが事前に指定したアカウント名とフォルダ名に基づいてメールを取得
' - すでに取得済み(EntryIDで判断)のメールは重複して取得しない
' - メール取得後、受信日時(またはReportItemの場合CreationTime)でソート
' - メールの本文はテキスト形式(Body)で取得
' - シート「メール一覧」にデータを蓄積
'
' ※実行前にOutlookを起動し、Excelは「メール一覧.xlsm」などマクロ有効ブックで本コードを保存しておくと便利です。
'-----------------------------------------

Sub Outlookのメール一覧取得()

    '===============================
    '【ユーザー指定項目：ここを事前設定してください】
    '===============================
    ' 特定のアカウント名でメールを絞りたい場合に記入
    '  例: "example@domain.com" あるいは Outlookに表示されているアカウント表示名
    ' 空欄の場合、全てのアカウントを対象とします。
    Const TARGET_ACCOUNT_NAME As String = ""
    
    ' 出力先シート名（このブック内に存在するか、新規作成します）
    Const OUTPUT_SHEET_NAME As String = "メール一覧"

    ' 取得したいOutlookフォルダパス
    ' 例1: "Inbox" → 受信トレイ
    ' 例2: "Sent Items" → 送信済みアイテム
    ' 例3: "Inbox\Processed" → 受信トレイ配下にある"Processed"フォルダ
    ' 空欄の場合は既定の受信トレイが対象になります
    Const TARGET_FOLDER_PATH As String = "Inbox"
    '===============================
    '【ここまでユーザー指定項目】
    '===============================

    Dim OutlookApp As Object        ' Outlook.Applicationを遅延バインディングで取得
    Dim OutlookNS As Object         ' Outlook.Namespace
    Dim st As Object                ' Outlook.Store
    Dim targetFolder As Object      ' 取得対象のフォルダ
    Dim itm As Object               ' 各アイテム(MailItem/ReportItem)
    Dim mailItem As Object          ' MailItem専用
    Dim reportItem As Object        ' ReportItem専用
    Dim wb As Workbook              ' 本ブック
    Dim ws As Worksheet             ' 出力先シート
    Dim lastRow As Long             ' データ書き込み先行
    Dim attachmentsList As String   ' 添付ファイル一覧文字列
    Dim existingIDs As Object       ' EntryID重複チェック用Dictionary
    Dim r As Long, idCheckRow As Long
    Dim j As Long

    Set wb = ThisWorkbook

    ' シート取得または作成
    On Error Resume Next
    Set ws = wb.Sheets(OUTPUT_SHEET_NAME)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add
        ws.Name = OUTPUT_SHEET_NAME
    End If

    ' 最終行取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastRow < 1 Then lastRow = 1

    ' ヘッダー設定
    ws.Cells(1, 1).Value = "アカウント名"
    ws.Cells(1, 2).Value = "送信者表示名"
    ws.Cells(1, 3).Value = "送信者メールアドレス"
    ws.Cells(1, 4).Value = "宛先"
    ws.Cells(1, 5).Value = "CC"
    ws.Cells(1, 6).Value = "件名"
    ws.Cells(1, 7).Value = "本文(テキスト形式)"
    ws.Cells(1, 8).Value = "添付ファイル名"
    ws.Cells(1, 9).Value = "受信日時相当"
    ws.Cells(1, 10).Value = "EntryID"

    ' 既存EntryID取得
    Set existingIDs = CreateObject("Scripting.Dictionary")
    For idCheckRow = 2 To lastRow
        If Not IsEmpty(ws.Cells(idCheckRow, 10).Value) Then
            existingIDs(ws.Cells(idCheckRow, 10).Value) = True
        End If
    Next idCheckRow

    ' Outlook起動
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookNS = OutlookApp.GetNamespace("MAPI")

    ' 指定フォルダ取得
    Set targetFolder = GetOutlookFolder(OutlookNS, TARGET_ACCOUNT_NAME, TARGET_FOLDER_PATH)
    If targetFolder Is Nothing Then
        MsgBox "指定したフォルダが見つかりませんでした。" & vbCrLf & _
               "アカウント名やフォルダ名を再確認してください。", vbExclamation
        GoTo Cleanup
    End If

    ' アイテム列挙
    For Each itm In targetFolder.Items
        Select Case TypeName(itm)
            Case "MailItem"
                Set mailItem = itm
                If existingIDs.Exists(mailItem.EntryID) Then GoTo NextItem

                Dim mSenderName As String, mSenderEmail As String
                mSenderName = mailItem.SenderName
                mSenderEmail = mailItem.SenderEmailAddress

                ' 本文はテキスト形式
                Dim mailBody As String
                On Error Resume Next
                mailBody = mailItem.Body
                On Error GoTo 0

                ' 添付ファイル名取得
                attachmentsList = ""
                If mailItem.Attachments.Count > 0 Then
                    For j = 1 To mailItem.Attachments.Count
                        attachmentsList = attachmentsList & mailItem.Attachments(j).FileName & "; "
                    Next j
                    If Right(attachmentsList, 2) = "; " Then
                        attachmentsList = Left(attachmentsList, Len(attachmentsList) - 2)
                    End If
                End If

                lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
                ws.Cells(lastRow, 1).Value = targetFolder.Store.DisplayName
                ws.Cells(lastRow, 2).Value = mSenderName
                ws.Cells(lastRow, 3).Value = mSenderEmail
                ws.Cells(lastRow, 4).Value = mailItem.To
                ws.Cells(lastRow, 5).Value = mailItem.CC
                ws.Cells(lastRow, 6).Value = mailItem.Subject
                ws.Cells(lastRow, 7).Value = mailBody
                ws.Cells(lastRow, 8).Value = attachmentsList
                ws.Cells(lastRow, 9).Value = mailItem.ReceivedTime
                ws.Cells(lastRow, 10).Value = mailItem.EntryID

                existingIDs(mailItem.EntryID) = True

            Case "ReportItem"
                Set reportItem = itm
                If existingIDs.Exists(reportItem.EntryID) Then GoTo NextItem

                attachmentsList = ""
                If reportItem.Attachments.Count > 0 Then
                    For j = 1 To reportItem.Attachments.Count
                        attachmentsList = attachmentsList & reportItem.Attachments(j).FileName & "; "
                    Next j
                    If Right(attachmentsList, 2) = "; " Then
                        attachmentsList = Left(attachmentsList, Len(attachmentsList) - 2)
                    End If
                End If

                lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
                ws.Cells(lastRow, 1).Value = targetFolder.Store.DisplayName
                ws.Cells(lastRow, 2).Value = ""
                ws.Cells(lastRow, 3).Value = ""
                ws.Cells(lastRow, 4).Value = ""
                ws.Cells(lastRow, 5).Value = ""
                ws.Cells(lastRow, 6).Value = reportItem.Subject
                ws.Cells(lastRow, 7).Value = ""
                ws.Cells(lastRow, 8).Value = attachmentsList
                ws.Cells(lastRow, 9).Value = reportItem.CreationTime
                ws.Cells(lastRow, 10).Value = reportItem.EntryID

                existingIDs(reportItem.EntryID) = True

            Case Else
                ' その他は無視
        End Select
NextItem:
    Next itm

    ' ソート(受信日時相当:9列目)
    Dim lastDataRow As Long
    lastDataRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If lastDataRow > 1 Then
        ws.Sort.SortFields.Clear
        ws.Sort.SortFields.Add Key:=ws.Range("I2:I" & lastDataRow), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ws.Sort
            .SetRange ws.Range("A1:J" & lastDataRow)
            .Header = xlYes
            .Apply
        End With
    End If

    ' 保存
    wb.Save

    MsgBox "処理が完了しました。指定フォルダ(" & TARGET_FOLDER_PATH & ")からメールを取得・一覧化しました。", vbInformation

Cleanup:
    Set reportItem = Nothing
    Set mailItem = Nothing
    Set targetFolder = Nothing
    Set OutlookNS = Nothing
    Set OutlookApp = Nothing
    Set ws = Nothing
    Set wb = Nothing
    Set existingIDs = Nothing
End Sub

Private Function GetOutlookFolder(ByVal oNS As Object, ByVal accountName As String, ByVal folderPath As String) As Object
    Dim st As Object
    Dim f As Object
    Dim subFolders() As String
    Dim i As Long

    If folderPath = "" Then
        ' フォルダパスが空ならデフォルト受信トレイ
        For Each st In oNS.Stores
            If accountName = "" Or InStr(st.DisplayName, accountName) > 0 Then
                On Error Resume Next
                Set f = st.GetDefaultFolder(6) ' 6 = olFolderInbox
                On Error GoTo 0
                If Not f Is Nothing Then
                    Set GetOutlookFolder = f
                    Exit Function
                End If
            End If
        Next st
        Exit Function
    End If

    subFolders = Split(folderPath, "\")

    For Each st In oNS.Stores
        If accountName = "" Or InStr(st.DisplayName, accountName) > 0 Then
            If subFolders(0) = "Inbox" Then
                On Error Resume Next
                Set f = st.GetDefaultFolder(6) ' Inbox
                On Error GoTo 0
            ElseIf subFolders(0) = "Sent Items" Then
                On Error Resume Next
                Set f = st.GetDefaultFolder(5) ' Sent Items
                On Error GoTo 0
            Else
                Set f = GetFolderByName(st, subFolders(0))
            End If

            If f Is Nothing Then GoTo NextStore

            For i = 1 To UBound(subFolders)
                Set f = f.Folders(subFolders(i))
                If f Is Nothing Then Exit For
            Next i

            If Not f Is Nothing Then
                Set GetOutlookFolder = f
                Exit Function
            End If
        End If
NextStore:
    Next st
End Function

Private Function GetFolderByName(ByVal st As Object, ByVal folderName As String) As Object
    Dim f As Object
    For Each f In st.GetRootFolder.Folders
        If f.Name = folderName Then
            Set GetFolderByName = f
            Exit For
        End If
    Next f
End Function