受信したメールの添付ファイルに日付と連番を付けて自動保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。

---

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

初心者なもので、大変恐縮ですが、教えてください。

元の添付ファイルのファイル名：abc

保存したいファイル名：yyyymmdd_01_abc
（年月日_その日の受信の連番（2桁）_添付ファイル名）

としたい場合、どうしたらよろしいでしょうか？

何卒よろしくお願いします。

---

年月日を追加したい場合は、Format 関数の第 1 パラメータに現在の日時を表す Now 関数を指定し、第 2 パラメータとして “yyyymmdd” という文字列を指定すれば可能です。
問題は「その日の受信の連番」をどうやって管理するかです。
ファイルやレジストリを使って管理する方法もあるのですが、今回は Outlook の StorageItem というオブジェクトを使ってみました。
StorageItem は受信トレイなどの任意のフォルダーに隠しアイテムとして設定などを保存することができるというものです。
マクロは以下のようになります。

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

' 連番を保持する StorageItem オブジェクト
Dim myStgCount As StorageItem
' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     On Error Resume Next
     Dim objMsg As MailItem
     '
     Set objMsg = Session.GetItemFromID(EntryIDCollection)
     If Not objMsg Is Nothing Then
         SaveAttachmentsWithDate objMsg
     End If
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachmentsWithDate(objMsg As MailItem)
     Const SAVE_PATH = "C:\attachments\"
     Dim objAttach As Attachment
     Dim iSerial As Integer
     Dim strDate As String
     Dim strFileName As String
     '
'
' ここで条件指定
'
     ' 日付を文字列に変換
     strDate = Format(Now, "YYYYMMDD_")
     ' 添付ファイルすべてについて処理
     For Each objAttach In objMsg.Attachments
         With objAttach
             ' 日ごとの連番を取得
             iSerial = GetSerialForToday()
             ' ファイル名に日付と連番を追加
             strFileName = SAVE_PATH & strDate & Format(iSerial, "0#_") & .FileName
             ' ファイルを保存
             .SaveAsFile strFileName
         End With
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub
'
' 日ごとの連番を取得する関数
Private Function GetSerialForToday()
     Const COUNT_SUBJECT = "GLOBAL_COUNTER"
     Dim fldInbox As Folder
     Dim myStgCount As StorageItem
     Dim strToday As String
     Dim propDate As UserProperty
     Dim propCount As UserProperty
     ' 連番を保持する StorageItem オブジェクトを取得
     If myStgCount Is Nothing Then
         Set fldInbox = Session.GetDefaultFolder(olFolderInbox)
         Set myStgCount = fldInbox.GetStorage(COUNT_SUBJECT, olIdentifyBySubject)
     End If
     ' 今日の日付を取得
     strToday = FormatDateTime(Now, vbShortDate)
     ' 連番を保持している日付を取得
     Set propDate = myStgCount.UserProperties.Find("CountDate")
     If propDate Is Nothing Then
         ' プロパティがなければ新規追加
         Set propDate = myStgCount.UserProperties.Add("CountDate", olText)
         propDate.Value = strToday
     End If
     ' 連番を取得
     Set propCount = myStgCount.UserProperties.Find("Counter")
     If propCount Is Nothing Then
         ' プロパティがなければ新規追加
         Set propCount = myStgCount.UserProperties.Add("Counter", olInteger)
         propCount.Value = 0
     End If
     ' 日付が変わっていたら連番をリセット
     If propDate.Value <> strToday Then
         propDate.Value = strToday
         propCount.Value = 1
     Else
         ' 日付が変わっていなければ連番を追加
         propCount.Value = propCount.Value + 1
     End If
     ' 変更後の連番と日付を保存
     myStgCount.Save
     GetSerialForToday = propCount.Value
End Function


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