【Excel VBA】ExcelからOutlookの受信メールを検索しリスト化

日々の業務のなかで、例えば特定のメールを受信した場合に、その内容を都度Excelのリストに転記するなんてこともあるかも知れません。また、過去に受信した大量のメールをExcelに転記してデータ化したいといった要望も結構ありそうな気がします。

よって今回はExcel VBAを使用して、Outlookのメールボックスから受信メールの一覧を参照する処理を紹介します。

事前準備(参照設定)

まずExcel VBAの参照設定にて以下の項目を有効化します。

Microsoft Outlook xx.x Object Library

今回のサンプルプログラムでは、以下の構成で動作します。

• 特定の条件でOutlookの受信メールを検索し、条件に当てはまるメールをExcelのシートに書き込む。
• メールボックスのサブフォルダ名(デフォルトフォルダでも可)、受信日時、件名を条件にリスト化するメールを絞り込める。
• 複数のメールアカウントを管理している場合は、アカウント名を指定する。
• メール本文は配列化し、必要によって解析等の処理が可能。
• Excelのシートにコマンドボタンを一つ配置し、そのクリックイベントに一連の処理を実装。

では早速サンプルプログラムを紹介します。尚、VBAでのOutlookの操作についてはインターネットでも情報が若干少ない為、上手く仕様を調査出来ず、若干強引な処理も見受けられるかと思いますが、ご了承ください。

サンプルコード

Sub ボタン1_Click()


    Dim TargetSheet As Worksheet
    Dim RowCount As Long
    Dim TargetSubFolder As String   '振分先サブフォルダ名
    Dim TargetReceivedDate As String	'対象受信日時
    Dim arrMailBody As Variant   	'メール文面内の項目格納用配列
    Dim itms As Variant
    Dim itms1 As Variant
    Dim UpdateCount As Integer      '更新データ件数
    Dim TargetAccount As String     '対象メールアカウント
    Dim i As Integer                '配列添字調整用変数
    Dim TargetSubject As String		'検索対象のメール件名文字列
    
    Dim objOutlookAcct As Outlook.Account          'Outlookのアカウント
    Dim objOutlookStore As Outlook.Store           'outlookのストア
    Dim objOutlook As Outlook.Application
    Dim objOutlookNameSp As Outlook.Namespace
    
    
        UpdateCount = 0
        'メールボックスのサブフォルダ名　サブフォルダが対象では無い場合は空文字列
        TargetSubFolder = "サブフォルダ名"
        'メールの受信日時で「特定の日付以降」を対象とする場合は日時を指定。
        TargetReceivedDate = "1900/01/01 00:00:00"
	TargetAccount = "対象のアカウント名"
	TargetSubject = "検索対象のメール件名"
        
        '書き込む先のシート名を定義します。
        Set TargetSheet = Worksheets("リスト用シート")

        '書き込み先シートのオートフィルタで絞り込みが有効になっている場合は解除します。
        If TargetSheet.FilterMode Then
            TargetSheet.ShowAllData
        End If

        '書き込み先シートの最終行を取得します。
        RowCount = TargetSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

        Set objOutlook = New Outlook.Application
        Set objOutlookAcct = objOutlook.Session.Accounts(TargetAccount)
        
    'エラー処理
    '　※存在しないアカウントを指定した場合ここでエラーが出るが、
    '　　存在チェックをして回避する仕様が不明な為、エラー処理で実装する。
    On Error GoTo ErrorProcess
    
        Set objOutlookStore = objOutlookAcct.DeliveryStore

    On Error GoTo 0

        'ポインターを砂時計にします。
        Application.Cursor = xlWait

        'サブフォルダの指定が無い場合の処理
        If IsNull(TargetSubFolder) Or TargetSubFolder = "" Then
        
            'Outlookのメールボックスを開いて全行を取得してループします。
            For Each itms In objOutlookStore.GetDefaultFolder(6).Items
            	
                'Excelへの書き込み対象かの判定をします。
                If itms.ReceivedTime > TargetReceivedDate And itms.Subject = TargetSubject Then
                
                    '本文の文字列を分解します。
                    '最初に本文内の改行コードをカンマに置換し、Split関数で配列に格納します。
                    arrMailBody = Split(Replace(itms.Body, vbCrLf, ","), ",")
                
		    '※※メール文面が配列arrMailBodyに格納されている為、必要によって固有の処理をしてください。
					
					
                    'Excelに書き込みます。
                    TargetSheet.Cells(RowCount, 1).Value = RowCount - 2             '1列目：連番
                    TargetSheet.Cells(RowCount, 2).Value = "'" & itms.ReceivedTime  '2列目：受信日時 ※先頭にシングルクォート挿入
                    TargetSheet.Cells(RowCount, 3).Value = itms.SenderEmailAddress  '3列目：送信者メールアドレス

		    '※※後は必要によって上記と同様の処理でメールの情報を取得してExcelに書き込んでください。

                    '書き込み行用のカウンターをカウントアップします。
                    RowCount = RowCount + 1
                    UpdateCount = UpdateCount + 1
                    Application.StatusBar = itms.ReceivedTime & " 受信分のメールを書き込みました。"
                End If
        
            Next
        
        Else
            'サブフォルダを指定してメールボックス全行を取得しループを回します。
            'サブフォルダを全て取得します。
            For Each itms1 In objOutlookStore.GetDefaultFolder(6).Folders
                '取得したサブフォルダのうち指定したフォルダ名かを判定します。
                If itms1.Name = TargetSubFolder Then
                
                    For Each itms In itms1.Items

                        'Excelへの書き込み対象かの判定をします。
                        If itms.ReceivedTime > TargetReceivedDate And itms.Subject = TargetSubject Then
                        
                            '本文の文字列を分解します。
                            '最初に本文内の改行コードをカンマに置換し、Split関数で配列に格納します。
                            arrMailBody = Split(Replace(itms.Body, vbCrLf, ","), ",")

			    '※※メール文面が配列arrMailBodyに格納されている為、必要によって固有の処理をしてください。
                        
                            'Excelに書き込みます。
		            TargetSheet.Cells(RowCount, 1).Value = RowCount - 2             '1列目：連番
		            TargetSheet.Cells(RowCount, 2).Value = "'" & itms.ReceivedTime  '2列目：受信日時 ※先頭にシングルクォート挿入
		            TargetSheet.Cells(RowCount, 3).Value = itms.SenderEmailAddress  '3列目：送信者メールアドレス

			    '※※後は必要によって上記と同様の処理でメールの情報を取得してExcelに書き込んでください。


                            '書き込み行用のカウンターをカウントアップします。
                            RowCount = RowCount + 1
                            UpdateCount = UpdateCount + 1
                            Application.StatusBar = itms.ReceivedTime & " 受信分のメールを書き込みました。"
                            
                        End If
                        
                    Next

            	End If
            	
            Next

        End If


        '終了処理
        'ポインターを砂時計状態から元に戻します。
        Application.Cursor = xlDefault
        Application.StatusBar = False
        
        Set objOutlookNameSp = Nothing
        Set objOutlookStore = Nothing
        Set objOutlookAcct = Nothing
        Set objOutlook = Nothing

        Set TargetSheet = Nothing
        
        If UpdateCount = 0 Then
            MsgBox "指定された条件のメールは存在しません。"
        Else
            MsgBox UpdateCount & " 件の受信メールをリストに追加しました。"
        End If

        'ブックを保存します。
        ActiveWorkbook.Save

        Exit Sub

お使いの環境によっては、不要な処理もいくつかあるかと思いますので、そこは対象の環境に合わせてカスタマイズして流用してください。

今回も閲覧して頂きましてありがとうございました。