【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形式で出力

6 件のコメント

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

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

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

      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

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

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

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

      申し訳ありません。

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

  • コメントを残す

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