【Excel VBA・Access VBA】Outlookの受信ボックスをフィルタして添付ファイルを保存

今回はExcelやAccessから、VBAでOutlookの受信ボックスを特定の条件でフィルタして、添付ファイルがあればそれを所定の場所に保存するサンプルコードを紹介します。

参照設定の追加

今回のサンプルプログラムを動かす場合は、Outlookを操作する為の参照設定を追加します。
以下の名称の参照設定を追加してください。

サンプルコードの注意事項

当サンプルコードでは、エラー処理は一切入れておりません。
必要によって追加してください。

ExcelとAccessの両方に同じプログラムをコピペして動作するのは確認していますが、ExcelやAccess、Outlookのバージョンによっては上手く動かない可能性もあります。
その場合はご了承ください。

当サンプルでは、受信ボックス内のメールの受信日時とメール件名を条件にフィルタを掛けて、取得したメールの一覧を元にループして送信者メールアドレスや本文などの情報を出力しつつ、添付ファイルがあれば指定した場所に保存します。

サンプルコード

Option Explicit


Sub OutlookSearch()

    Dim objOutlookAcct As Outlook.Account
    Dim objOutlookStore As Outlook.Store
    Dim objOutlook As Outlook.Application
    Dim MyItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim TargetAccount As String
    Dim itms As Variant
    Dim SaveFolder As String
    Dim FullName As String
    Dim i As Integer
    Dim TargetStartDate As String
    Dim FilterString As String
    Dim TargetSubject As String
    

        'メールアカウントを指定します。
        TargetAccount = "test_user@example.com"
        '保存先フォルダを指定します。
        SaveFolder = "C:\work1\"
        
        'フィルタ条件の下限受信日を指定します。
        TargetStartDate = "2021/03/25"
        'フィルタ条件の件名を指定します。
        TargetSubject = "件名テスト"
             
        'フィルターの文字列を指定します。※jetクエリの為文字列の部分一致不可
        FilterString = "[ReceivedTime] >= '" & TargetStartDate & "' And [Subject] = '" & TargetSubject & "'"

        'Outlookの必要なオブジェクトを生成します。
        Set objOutlook = New Outlook.Application
        Set objOutlookAcct = objOutlook.Session.Accounts(TargetAccount)
        Set objOutlookStore = objOutlookAcct.DeliveryStore
        
        'Outlookの受信ボックスを取得します。※GetDefaultFolder(6)が受信ボックス
        Set MyItems = objOutlookStore.GetDefaultFolder(6).Items
        'ItemsコレクションにRestrictでフィルタを適用します。
        Set myRestrictItems = MyItems.Restrict(FilterString)

            'フィルタで絞り込んだItemsコレクションでループします。
            For Each itms In myRestrictItems
                '参考までに幾つかのデータを出力します。
                Debug.Print itms.ReceivedTime       '受信日時
                Debug.Print itms.Subject            '件名
                Debug.Print itms.SenderEmailAddress '送信者アドレス
                Debug.Print itms.Body               '本文
            
                '添付ファイルがあればファイル数分ループします。
                For i = 1 To itms.Attachments.Count
                    '保存先のフルパスを生成します。
                    FullName = SaveFolder & itms.Attachments.Item(i)
                    'ファイルを保存します。※同名ファイルがあれば上書きします。
                    itms.Attachments.Item(i).SaveAsFile FullName
                Next i
            
            Next

        'オブジェクトを破棄して終了します。
        Set myRestrictItems = Nothing
        Set MyItems = Nothing
        Set objOutlookStore = Nothing
        Set objOutlookAcct = Nothing
        Set objOutlook = Nothing

End Sub

処理の解説

最後に

今回はExcelやAccessからVBAを使用して、Outlookの受信ボックス内のメールを特定の条件でフィルタして、絞り込まれたメール内に添付ファイルがあれば保存するといった処理のサンプルプログラムを紹介しました。

実はかなり以前に、VBAを使ってOutlookを受信ボックスを検索してExcelシートに書き出すといったサンプルプログラムを当ブログで紹介していたのですが、仕事で作ったプログラムを急遽ブログ用に作り替えて、あまり調整しないまま公開してしまっており、見た目が悪く、そのままコピペするだけでは使えなかったり、フィルタでの絞り込みを掛けていなかったりでお世辞にもわかりやすいサンプルとは言えなかったこともあり、リメイクのつもりで需要のありそうな処理だけに絞ったサンプルプログラムを書いてみました。

今回のサンプルプログラムが貴方の助けになれば幸いです。

今回も読んでいただきましてありがとうございました。
それでは皆さまごきげんよう。