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


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


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

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

元の添付ファイルのファイル名: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

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

受信したメールの添付ファイルに日付と連番を付けて自動保存するマクロ」への2件のフィードバック

  1. いつも参考にさせていただいております

    こちらの”受信したメールの添付ファイルに日付と連番を付けて自動保存するマクロ”
    を仕分けルールのスクリプトで動作し、添付ファイルの保存後に印刷もするものにしたく調べながら編集しているんですが、うまく動作してくれません。お力添えお願いできませんでしょうか?よろしくお願いいたします。

    • まず、マクロの先頭部分に以下を追加します。

      Private Declare Function ShellExecute Lib “shell32.dll” Alias “ShellExecuteA” _
      (ByVal hwnd As Long, ByVal lpszOp As String, _
      ByVal lpszFile As String, ByVal lpszParams As String, _
      ByVal LpszDir As String, ByVal FsShowCmd As Long) _
      As Long

      そして、.SaveAsFile strFileName で添付ファイルを保存した後に以下の記述で印刷ができます。

      ShellExecute 0, “print”, strFileName, 0, SAVE_PATH, 0

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト /  変更 )

Google フォト

Google アカウントを使ってコメントしています。 ログアウト /  変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト /  変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト /  変更 )

%s と連携中