特定のフォルダーのメールの添付ファイルを日付と送信者のフォルダーに保存するマクロ

コメントにて以下のご要望をいただきました。


コメント

いつも大変参考にさせていただいております

受信したメールの添付ファイルを自動作成した日付フォルダ/送信者フォルダへ保存&添付ファイルリストをExcel形式で出力同じフォルダ内の保存格納 するスクリプトを書いているのですがなにぶん勉強不足でうまくいきません。

加筆修正お願いできませんでしょうか。。日付フォルダを自動作成まではネットで調べてできたのですが、、、

よろしくお願いいたします。

<コード省略>


コメントでいただいたコードでほとんど完成していたのですが、以下の処理を追加しました。

  • 日付のフォルダーの下に送信者名のフォルダーを作成する。この時、送信者名にフォルダー名では使えない文字 (/、: など) が含まれていたら _ に置換する。
  • 同名のファイルが既に保存されていたら、ファイル名に連番をつけて別名で保存する。
  • Excel ファイルを保存後にクローズする。

追加後のマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub SaveAttachments4()
     Const ROOT_PATH = "C:\Users\username\Documents\outlook_temp"
     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 = ROOT_PATH & "\" & strDay
     '日付フォルダがなければ作成
     If Dir(strPath, vbDirectory) = "" Then
         MkDir strPath
     End If
     For Each objItem In objFolder.Items
         Dim strSubPath As String
         Dim strFileName As String
         ' 送信者名をパスに追加 (フォルダに使用できない文字は _ に置換)
         strSubPath = strPath & ReplaceSpecialChar(objItem.SenderName) & "\"
         For i = 1 To objItem.Attachments.Count
             '添付ファイルに拡張子がある場合のみ処理
             If InStr(objItem.Attachments.Item(i), ".") > 0 Then
                 ' 差出人名のフォルダがなければ作成
                 If Dir(strSubPath, vbDirectory) = "" Then
                     MkDir strSubPath
                 End If
                 ' すでに同名のファイルが存在したら連番を付与
                 strFileName = MakeFileName(strSubPath, objItem.Attachments.Item(i).FileName)
                 ' 添付ファイルを保存
                 objItem.Attachments.Item(i).SaveAsFile strSubPath & strFileName
                 '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) = strSubPath & strFileName '添付ファイルのパス”
                 n = n + 1
             End If
         Next i
     Next objItem
     '添付ファイル保存場所へExcelを保存
     objBook.SaveAs strPath & "添付リスト.xlsx"
     objBook.Close
     Set objItem = Nothing
     Set objInbox = Nothing
     Set objFolder = Nothing
     Set objSheet = Nothing
End Sub
'
' フォルダ名に使用できない文字を _ に置き換える関数
Private Function ReplaceSpecialChar(strText As String) As String
     ReplaceSpecialChar = ""
     For i = 1 To Len(strText)
         ch = Mid(strSubject, i, 1)
         If InStr("\/:*?""|", ch) > 0 Then
             ch = "_"
         End If
         ReplaceSpecialChar = ReplaceSpecialChar & ch
     Next
End Function
'
' ファイル名が重複した場合に連番を付与する関数
Private Function MakeFileName(strFolder As String, strOrgFileName As String)
     Dim strFileName As String
     Dim strBase As String
     Dim strExt As String
     Dim c As Integer
     strBase = Left(strOrgFileName, InStr(strOrgFileName, ".") - 1)
     strExt = Mid(strOrgFileName, InStr(strOrgFileName, "."))
     strFileName = strOrgFileName
     c = 1
     '
     While Dir(strFolder & strFileName) <> ""
         strFileName = strBase & c & strExt
         c = c + 1
     Wend
     MakeFileName = strFileName
End Function

マクロの登録方法やメニューへの追加について