Outlook VBA

【Outlook VBA】受信したメールの添付ファイルを自動作成した日付フォルダへ保存＆添付ファイルリストをExcel形式で出力

前回、【Outlook VBA】受信したメールの添付ファイルを指定フォルダへ保存＆添付ファイルリストをExcel形式で出力する方法を紹介しましたが、保存先フォルダを指定先のパスにさらに日ごとのフォルダを自動作成しそこへ保存する方法を紹介します。

【Outlook VBA】受信したメールの添付ファイルを指定フォルダへ保存＆添付ファイルリストをExcel形式で出力

添付ファイルを指定のフォルダへ保存したときに気づいたこと

添付ファイルを指定フォルダへ保存したときに、どのメールの添付ファイルかわからなくなりました。件数が多いほど厄介ですね。

前回は添付ファイルかどのメールのものであるかわかるリストを出力する機能を追加しましたが、さらに日別にフォルダを作成しそこへ添付ファイルを格納する機能を追加したいと思います。

完成したマクロは以下の通りです。

マクロを設置する下準備をする。

以下を参考にVBAコードを配置する場所を表示させます。

Outlook VBAをはじめよう!

今回Excelの機能を使いますので、参照設定からExcel Objectを指定し有効化します。
[開発]タブをクリックし、「Visual Basic」ボタンをクリックします。
[ツール(T)]メニュー＞[参照設定(R)]で「Microsoft Excel XX.X Object Library」にチェックを入れます。

この設定が終えたら一度Outlookを再起動させてください。

マクロを登録する

「開発」タブ>「Visual Basic」を押します。

「Visual Basic Editor」にて、[Project1] > [Microsoft Outlook Objects] > [ThisOutlookSession] を開きます。

右のコードエリアへ、以下のコードを貼り付けて保存します。

Sub 添付ファイルを保存かつ添付ファイルリストをExcelへ出力()

    Dim objInbox As Object
    Dim objFolder As Object
    Dim strPath As String
    Dim i As Long
    
    '日付用定義
    Dim strDay As String
    
    'フォルダ名をyyyymmdd形式で入力
    strDay = Format(Date, "yyyymmdd")
    strDay = strDay & "\"
    
    'Excel用定義
    Dim myExcel As Excel.Application
    Dim objBook As Excel.Workbook
    Dim objSheet As Excel.worksheet
    Dim n As Long
    
    'Excelオブジェクト生成、ブックの追加
    Set myExcel = CreateObject("Excel.Application")
    Set objBook = myExcel.Workbooks.Add()
    Set objSheet = objBook.sheets(1)

    '項目目を追加
    objSheet.Cells(1, 1) = "ID"
    objSheet.Cells(1, 2) = "件名"
    objSheet.Cells(1, 3) = "送信者"
    objSheet.Cells(1, 4) = "受信日時"
    objSheet.Cells(1, 5) = "添付ファイル"
    objSheet.Cells(1, 6) = "添付ファイルのパス"
    
    '添付ファイルリストを書き込む行の位置
    n = 2
    
     
    Set objInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    
    '添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(＜フォルダ名＞)」を追加してください。
    Set objFolder = objInbox.Folders.Item("1.サブフォルダ").Folders.Item("1-1.サブフォルダ")
    
    '添付ファイルの保存先をパスで指定します。※日付フォルダ追加
    strPath = "D:\test\outlook_temp\" & strDay
    
    '日付フォルダがなければ作成
    If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
    End If
    
    For Each objitem In objFolder.Items
        For i = 1 To objitem.Attachments.Count
            '添付ファイルに拡張子がある場合のみ処理します。
            If InStr(objitem.Attachments.Item(i), ".") <> 0 Then
            
                objitem.Attachments.Item(i).SaveAsFile strPath & objitem.Attachments.Item(i)
                
               'Excelへ添付ファイル情報を追加
                objSheet.Cells(n, 1) = n - 1
                objSheet.Cells(n, 2) = objitem.ConversationTopic '件名
                objSheet.Cells(n, 3) = objitem.SenderName '送信者
                objSheet.Cells(n, 4) = objitem.ReceivedTime '受信日時
                objSheet.Cells(n, 5) = objitem.Attachments.Item(i) '添付ファイル
                objSheet.Cells(n, 6) = strPath & objitem.Attachments.Item(i)   '添付ファイルのパス"
                n = n + 1
            End If
        Next i
    Next objitem
 
    '添付ファイル保存場所へExcelを保存　※ファイル名は適当な名前に変えてください。
    objBook.SaveAs strPath & "添付ファイルリスト.xlsx"
    
    'Excelブックを閉じます。
    objBook.Close SaveChanges:=False
    
    Set objitem = Nothing
    Set objInbox = Nothing
    Set objFolder = Nothing
    Set objSheet = Nothing
    Set objitem = Nothing

End Sub

試しに添付ファイル付きメールをフォルダへ格納して動作してみる

早速添付ファイルとExcelの添付ファイルリストが自動生成された日付フォルダへ保存されるか確認をしてみましょう。

添付付きメールを二階層目の「1-1.サブフォルダ」へ移動します。

ソースコードを編集します。
添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(＜フォルダ名＞)」を追加してください。
Set objFolder = objInbox.Folders.Item(“1.サブフォルダ”).Folders.Item(“1-1.サブフォルダ”)

添付ファイルとExcelの添付ファイルリストの保存先となるフォルダのパスを以下ソースコードの””内に指定します。
strPath = “C:\Users\extan\Documents\outlook_temp\” & strDay

次にoutlook本体に戻り「開発」タブの「マクロ」＞「添付ファイルを保存かつ添付ファイルリストをExcelへ出力」を押下します。

はい！添付ファイルとExcelの添付ファイルリストが指定フォルダへ保存されましたね。

↓

添付ファイルのパスは日付フォルダ付きになっていますね。

おまけ:本日受信分の添付ファイルに絞り込んで本日分のフォルダへ出力する

当日分のフォルダにしたわけですから、当日受信分の添付ファイルに絞り込んで本日分のフォルダへ出力したいと思いました。
コードは以下となります。

Sub 当日受信の添付ファイルを保存かつ添付ファイルリストをExcelへ出力()

    Dim objInbox As Object
    Dim objFolder As Object
    Dim strPath As String
    Dim i As Long
    
    '日付用定義
    Dim strDaytemp As String
    Dim strDay As String
    Dim strReceivetime As String
    
    
    'フォルダ名をyyyymmdd形式で入力
    strDaytemp = Format(Date, "yyyymmdd")
    strDay = strDaytemp & "\"
    
    'Excel用定義
    Dim myExcel As Excel.Application
    Dim objBook As Excel.Workbook
    Dim objSheet As Excel.worksheet
    Dim n As Long
    
    'Excelオブジェクト生成、ブックの追加
    Set myExcel = CreateObject("Excel.Application")
    Set objBook = myExcel.Workbooks.Add()
    Set objSheet = objBook.sheets(1)

    '項目目を追加
    objSheet.Cells(1, 1) = "ID"
    objSheet.Cells(1, 2) = "件名"
    objSheet.Cells(1, 3) = "送信者"
    objSheet.Cells(1, 4) = "受信日時"
    objSheet.Cells(1, 5) = "添付ファイル"
    objSheet.Cells(1, 6) = "添付ファイルのパス"
    
    '添付ファイルリストを書き込む行の位置
    n = 2
    
     
    Set objInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    
    '添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(＜フォルダ名＞)」を追加してください。
    Set objFolder = objInbox.Folders.Item("1.サブフォルダ").Folders.Item("1-1.サブフォルダ")
    
    '添付ファイルの保存先をパスで指定します。※日付フォルダ追加
    strPath = "D:\test\outlook_temp\" & strDay
    
    '日付フォルダがなければ作成
    If Dir(strPath, vbDirectory) = "" Then
        MkDir strPath
    End If
    
    For Each objItem In objFolder.Items
        For i = 1 To objItem.Attachments.Count
            strReceivetime = Format(objItem.ReceivedTime, "yyyymmdd")
            
            '添付ファイルに拡張子があり、当日受信したアイテムのみ処理します。
            If InStr(objItem.Attachments.Item(i), ".") <> 0 Then
                If strReceivetime = strDaytemp Then
                    objItem.Attachments.Item(i).SaveAsFile strPath & objItem.Attachments.Item(i)
                    
                    'Excelへ添付ファイル情報を追加
                    objSheet.Cells(n, 1) = n - 1
                    objSheet.Cells(n, 2) = objItem.ConversationTopic '件名
                    objSheet.Cells(n, 3) = objItem.SenderName '送信者
                    objSheet.Cells(n, 4) = objItem.ReceivedTime '受信日時
                    objSheet.Cells(n, 5) = objItem.Attachments.Item(i) '添付ファイル
                    objSheet.Cells(n, 6) = strPath & objItem.Attachments.Item(i) '添付ファイルのパス"
                n = n + 1
                End If
            End If
        Next i
    Next objItem
 
    '添付ファイル保存場所へExcelを保存　※ファイル名は適当な名前に変えてください。
    objBook.SaveAs strPath & "添付ファイルリスト.xlsx"
    
 
    Set objItem = Nothing
    Set objInbox = Nothing
    Set objFolder = Nothing
    Set objSheet = Nothing
    '添付ファイルリストクローズ
    objBook.Close
    Set objBook = Nothing

End Sub

これで本日受信分限定で添付ファイルが出力されたかと思います。
なお時刻は、PCのタイムゾーンに依存するため、タイムゾーン設定を変える場合は集計結果が異なりますのでご注意ください。

さいごに

いかがでしょうか。これまで添付ファイルの保存の仕方としてご紹介しましたが、添付ファイル以外にもメールそのものやカレンダー、連絡表など別のアイテムでも出力処理が可能です。

次回もいろいろな使い方をとりあげていきたいと思います！

【Outlook VBA】受信したメールの添付ファイルを指定フォルダへ保存する

【Outlook VBA】受信したメールの添付ファイルを指定フォルダへ保存＆添付ファイルリストをExcel形式で出力



この記事の関連キーワード

こちらの記事の関連キーワード一覧です。クリックするとキーワードに関連する記事一覧が閲覧できます。


「メール」の関連記事

こちらの記事の内容「メール」に関連する記事一覧です。






8 件のコメント

  • 直ぐに活用できる情報を公開して頂きありがとうございます。
    初心者なのでとても勉強になります。

    添付ファイルがあるメールのフォルダに、共有メールボックスの受信トレイを指定することはできますか？

    最初にメールアドレスを指定し
    Const SHARED_MAILBOX = “メールアドレス”

    添付ファイルがあるメールのフォルダを指定で
    Set recOther = Session.CreateRecipient(SHARED_MAILBOX)
    Set fldOtherInbox = Session.GetSharedDefaultFolder(recOther, olFolderInbox)

    としたのですが、
    For Each objItem In objFolder.Items

    の部分で下記エラーが出て先に進みません
    「オブジェクト変数または with ブロック変数が設定されていません」

    指定方法を教えて頂けると大変助かります。
    よろしくお願いします。

    返信する

    • いつもご利用ありがとうございます。

      共有メールボックスの受信トレイの指定が可能かについては可能となります。

      「オブジェクト変数または with ブロック変数が設定されていません」となる件ですが、
      GetSharedDefaultFolderメッソドでオブジェクトが取得できずNothingとなっていることが要因かと思われます。
      GetSharedDefaultFolderメッソドを利用する場合は下記の条件がありますので、ご確認いただけますでしょうか。
      ・同一ドメインに参加しているか（別ドメインのメールボックスは対象外）
      ・実行アカウントに対し付与されているアクセス権はすべてが参照または編集できる権限になっているか
      ・共有メールボックスのフォルダが「受信トレイ」になっているか（olFolderInboxは「受信トレイ」以外のフォルダは対象外）
      その点をご確認頂きたくお願いいたします。

      また、上記エラーの原因と対処法は以下の記事にまとめておりますので、よろしければこちらもご参照ください。
      https://extan.jp/?p=2799

      返信する

  • おまけで紹介されている「本日受信分の添付ファイルに絞り込んで本日分のフォルダへ出力する」コードが、本文中のオリジナル版のコードとほぼ同じになっているように見えます。当方初心者なので勘違いであれば申し訳ありません。
    「本日受審分」を絞り込むためのコードをどの部分なのか教えていただければ幸いです。
    とてもわかりやすく実用的な情報を公開していただきありがとうございます。

    返信する

    • ご連絡ありがとうございます。
      「本日受信分の添付ファイルに絞り込んで本日分のフォルダへ出力する」コードにつきまして、確認したところ当日受信の判定式が抜けておりました。

      申し訳ありません。

      修正をいたしましたので、ご参考頂きたくお願いいたします。
      また不明点、要望などございましたらコメントいただければと存じます。

      返信する

  • コード中の添付ファイルリスト.xlsxがマクロ処理完了後もExcelが掴んでしまっている不具合を訂正しました。

    返信する

  • 日付フォルダの中にさらに送信者のフォルダを自動で作って、日付/送信者ごとに添付ファイルを格納できないでしょうか？

    可能ならコードお願いいたします。

    返信する

    • おそくなりましたが、以下でいかがでしょうか。
      タイトル長めです。。。

      Sub 日付､送信者単位にフォルダ作成し添付ファイルを保存かつ添付ファイルリストをExcelへ出力()

      Dim objInbox As Object
      Dim objFolder As Object
      Dim strPath As String
      Dim i As Long

      ‘日付用定義
      Dim strDay As String

      ‘フォルダ名をyyyymmdd形式で入力
      strDay = Format(Date, “yyyymmdd”)
      strDay = strDay & “\”

      ‘Excel用定義
      Dim myExcel As Excel.Application
      Dim objBook As Excel.Workbook
      Dim objSheet As Excel.worksheet
      Dim n As Long

      ‘Excelオブジェクト生成、ブックの追加
      Set myExcel = CreateObject(“Excel.Application”)
      Set objBook = myExcel.Workbooks.Add()
      Set objSheet = objBook.sheets(1)

      ‘項目目を追加
      objSheet.Cells(1, 1) = “ID”
      objSheet.Cells(1, 2) = “件名”
      objSheet.Cells(1, 3) = “送信者”
      objSheet.Cells(1, 4) = “受信日時”
      objSheet.Cells(1, 5) = “添付ファイル”
      objSheet.Cells(1, 6) = “添付ファイルのパス”

      ‘添付ファイルリストを書き込む行の位置
      n = 2

      Set objInbox = GetNamespace(“MAPI”).GetDefaultFolder(olFolderInbox)

      ‘添付ファイルがあるメールのフォルダを指定します。2階層以上ある場合は「.Folders.Item(＜フォルダ名＞)」を追加してください。
      Set objFolder = objInbox.Folders.Item(“1.サブフォルダ”).Folders.Item(“1-1.サブフォルダ”)

      ‘添付ファイルの保存先をパスで指定します。※日付フォルダ追加
      strPath = “C:\Users\takahiro\Documents\outlook_temp\” & strDay

      ‘日付フォルダがなければ作成
      If Dir(strPath, vbDirectory) = “” Then
      MkDir strPath
      End If

      For Each objitem In objFolder.Items
      For i = 1 To objitem.Attachments.Count
      ‘添付ファイルに拡張子がある場合のみ処理します。
      If InStr(objitem.Attachments.Item(i), “.”) <> 0 Then

      ‘送信者フォルダを追加
      ‘送信者フォルダがなければ作成
      If Dir(strPath & “\” & objitem.SenderName, vbDirectory) = “” Then
      MkDir strPath & objitem.SenderName
      End If

      objitem.Attachments.Item(i).SaveAsFile strPath & objitem.SenderName & “\” & objitem.Attachments.Item(i)

      ‘Excelへ添付ファイル情報を追加
      objSheet.Cells(n, 1) = n – 1
      objSheet.Cells(n, 2) = objitem.ConversationTopic ‘件名
      objSheet.Cells(n, 3) = objitem.SenderName ‘送信者
      objSheet.Cells(n, 4) = objitem.ReceivedTime ‘受信日時
      objSheet.Cells(n, 5) = objitem.Attachments.Item(i) ‘添付ファイル
      objSheet.Cells(n, 6) = strPath & objitem.SenderName & “\” & objitem.Attachments.Item(i) ‘添付ファイルのパス”
      n = n + 1
      End If
      Next i
      Next objitem

      ‘添付ファイル保存場所へExcelを保存　※ファイル名は適当な名前に変えてください。
      objBook.SaveAs strPath & “添付ファイルリスト.xlsx”

      ‘Excelブックを閉じます。
      objBook.Close SaveChanges:=False

      Set objitem = Nothing
      Set objInbox = Nothing
      Set objFolder = Nothing
      Set objSheet = Nothing
      Set objitem = Nothing

      End Sub

      返信する

    • コメントを残す

    メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

    CAPTCHA ImageChange Image

    RECOMMENDこちらの記事も人気です。