【備忘メモ】VBA で Outlook の受信メールを取得する

はじめに

Outlook の受信メールを VBA で取得することがが必要になりそうなので、自分用のメモとして残しておきます。

＜参考サイト＞
・Outlook VBAのオブジェクトについて
・エクセルVBAでOutlookの受信メールをワークシートに書き出す方法
・Microsoftの分かりにくい公式サイト

1. 参照設定

VBAメニューの「ツール」から「参照設定」を開き、Microsoft Outlook X.X Object Libraryにチェックを入れてOKボタンを押します。

2. 受信トレイのメールを取得するサンプルコード

受信トレイ（サブフォルダを除く）のメールを全て取得して、Excelのシートに書き出すサンプルコードです。

Excel VBA であれば、コピペでそのまま動くと思いますが、お薦めしません。
全件取得して、Excelシートに書き出すので時間が掛かるためです（処理速度を上げるなら「こちらのサイト」を参照）。
試しに実行するのであれば、For 文のところを For i = 1 To 10 などとして、取得数を限定して実行することをお薦めします。

受信トレイのメールを取得

Sub GetOutlookReceivedEmail()
    'Outlookを操作するインスタンス取得
    Dim objOutlook As New Outlook.Application
    
    'Outlook の NameSpace オブジェクトを取得
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = objOutlook.GetNamespace("MAPI")
    
    '受信トレイフォルダーを取得
    Dim myFolder As Folder
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    
    '[Sheet1]のオブジェクトを取得
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim i As Long
    For i = 1 To myFolder.Items.Count '受信トレイのメール数だけループする
        On Error Resume Next '取得時にエラーが出る場合を回避（配信不能のお知らせメールなど）
        
        ws.Cells(i, 1).Value = myFolder.Items.Item(i).SenderName '送信者名
        ws.Cells(i, 2).Value = myFolder.Items.Item(i).SenderEmailAddress '送信者アドレス
        ws.Cells(i, 3).Value = myFolder.Items.Item(i).ReceivedByName '受信者名
        ws.Cells(i, 4).Value = myFolder.Items.Item(i).To 'To（表示名）
        ws.Cells(i, 5).Value = myFolder.Items.Item(i).CC 'CC（表示名）
        ws.Cells(i, 6).Value = myFolder.Items.Item(i).BCC 'BCC（表示名）
        ws.Cells(i, 7).Value = myFolder.Items.Item(i).ReceivedTime '受信時間
        ws.Cells(i, 8).Value = myFolder.Items.Item(i).SentOn '送信時間
        
        ws.Cells(i, 9).Value = myFolder.Items.Item(i).Subject '件名
        ws.Cells(i, 10).Value = myFolder.Items.Item(i).Body '本文
        
        If Err.Number > 0 Then
            ws.Cells(i, 11).Value = Err.Number & ", " & Err.Description 'とりあえずエラーも表示しておこう
        End If
        
        On Error GoTo 0
    Next
End Sub

簡単な説明

①～③は定型です。

① Outlookオブジェクト取得
最初の1行で、Outlookを操作するインスタンスを取得しています。

② NameSpace オブジェクト取得
名前空間"MAPI"を使用すれば、Outlook の NameSpace オブジェクト を取得できます。
これにより、「ユーザーのメッセージ ストアに格納されたすべての Outlook データへアクセスでき」るとのことです（公式の注釈）。

③ 受信トレイフォルダーのオブジェクト取得
GetDefaultFolder メソッドを使用して「受信トレイフォルダ」のオブジェクトを取得します。
引数の olFolderInbox は「受信トレイフォルダ」を取得することを意味します。

なお、送信トレイは olFolderOutbox となります。他のフォルダを取得することはあまりないと思いますが、必要があれば「OlDefaultFolders enumeration」を参照してみてください（記載されている数値を引数に入れても OK です）。

④ WorkSheetのオブジェクト取得
書き込み先のExcelシートを指定しています。
実在するシート名を指定します。

⑤ メールの情報を取得してシートに書き出し
For 文のところです。
必要そうなプロパティを適当に選択しています。

プロパティ	内容	備考
SenderName	送信者名
SenderEmailAddress	送信者アドレス
ReceivedByName	受信者名
To	To（表示名）	アドレスでなく表示名です
CC	CC（表示名）	アドレスでなく表示名です
BCC	BCC（表示名）	受信トレイだと取得できないと思います
ReceivedTime	受信時間
SentOn	送信時間
Subject	件名
Body	本文
HTMLBody	HTML形式の本文

⑥ エラー処理
例えば、配信不能のお知らせメールなどは、件名、本文などの情報しか取得できません。
取得できない情報にアクセスしようとするとエラーが出ます。
そのため、On Error Resume Next を使用して、エラーが出ても処理を続けるようにしています。

＜参考サイト＞
・Outlook.MailItemから送信者のメールアドレスを取得する

3. サブフォルダの名前の取得

受信トレイのメールだけ取得しても、必要条件を充たさない場合があります。
その場合は、サブフォルダのメールも取得する必要があります。

とりあえず、サブフォルダの名前と、フォルダ内にあるメール数を取得するコードを書くと次のようになります。

Sub GetSubFolderName()
    'Outlookを操作するインスタンス取得
    Dim objOutlook As New Outlook.Application

    'Outlook の NameSpace オブジェクトを取得
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = objOutlook.GetNamespace("MAPI")

    '受信トレイフォルダーを取得
    Dim myFolder As Folder
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    
    'サブフォルダの名前とメール数を取得
    Dim i As Long
    Dim mySubFolder As Folder
    For i = 1 To myFolder.Folders.Count
        Set mySubFolder = myFolder.Folders(i)
        Debug.Print mySubFolder.Name
        Debug.Print mySubFolder.Items.Count
    Next
End Sub

受信トレイフォルダのオブジェクトのFolders プロパティを使用することで、サブフォルダのリスト（Folders オブジェクト）を取得することができます。

For 文のところで、Folders オブジェクトから1つずつ、サブフォルダの Folder オブジェクト を取得して、サブフォルダ名と、格納しているメール数を取得しています。

4. サブフォルダのメールを取得するサンプルコード

以上の内容を踏まえて、サブフォルダの受信メールを取得するサンプルコードを書くと次のとおりです。

Sub GetOutlookReceivedEmailFromSubFolder()
    'Outlookを操作するインスタンス取得
    Dim objOutlook As New Outlook.Application

    'Outlook の NameSpace オブジェクトを取得
    Dim myNamespace As Outlook.Namespace
    Set myNamespace = objOutlook.GetNamespace("MAPI")

    '受信トレイフォルダーを取得
    Dim myFolder As Folder
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)

    '[Sheet1]のオブジェクトを取得
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim i As Long, j As Long, tmp As Long: tmp = 0
    Dim mySubFolder As Folder
    For i = 1 To myFolder.Folders.Count
        Set mySubFolder = myFolder.Folders(i) 'サブフォルダのオブジェクトを1つずつ取得
        
        For j = 1 To mySubFolder.Items.Count '受信トレイのメール数だけループする
            On Error Resume Next '取得時にエラーが出る場合を回避（配信不能のお知らせメールなど）
    
            ws.Cells(j + tmp, 1).Value = mySubFolder.Items.Item(j).SenderName '送信者名
            ws.Cells(j + tmp, 2).Value = mySubFolder.Items.Item(j).SenderEmailAddress '送信者アドレス
            ws.Cells(j + tmp, 3).Value = mySubFolder.Items.Item(j).ReceivedByName '受信者名
            ws.Cells(j + tmp, 4).Value = mySubFolder.Items.Item(j).To 'To（表示名）
            ws.Cells(j + tmp, 5).Value = mySubFolder.Items.Item(j).CC 'CC（表示名）
            ws.Cells(j + tmp, 6).Value = mySubFolder.Items.Item(j).BCC 'BCC（表示名）
            ws.Cells(j + tmp, 7).Value = mySubFolder.Items.Item(j).ReceivedTime '受信時間
            ws.Cells(j + tmp, 8).Value = mySubFolder.Items.Item(j).SentOn '送信時間（たぶん）
    
            ws.Cells(j + tmp, 9).Value = mySubFolder.Items.Item(j).Subject '件名
            ws.Cells(j + tmp, 10).Value = mySubFolder.Items.Item(j).Body '本文
    
            If Err.Number > 0 Then
                ws.Cells(j + tmp, 11).Value = Err.Number & ", " & Err.Description 'とりあえずエラーも表示しておこう
            End If
    
            On Error GoTo 0
        Next
        tmp = tmp + j - 1
    Next
End Sub

さいごに

実際の業務では、受信日時（ReceivedTime）や、件名（Subject）などで絞り込みを行った上で、メールを取得することになると思います。
また、サブフォルダのサブフォルダを取得する場合は、再帰処理などを使用すれば、うまくいきそうです。