Outlookで添付ファイルの自動保存を目指して――一応、完成品

メールに添付されて送られてきたPDFファイルを、一つはそのまま、もう一つはファイル名を加工して保存するOutlookのマクロ。OUTLOOK研究所さんをはじめ、多くの先人の知恵を借りて作ったのが下のマクロ。

件名が「ファイルです」となっているメールに対して、添付ファイルを保存する。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim i As Integer

Dim c As Integer

Dim colID As Variant

If InStr(EntryIDCollection, ",") = 0 Then

SaveAttachments EntryIDCollection

Else

colID = Split(EntryIDCollection, ",")

For i = LBound(colID) To UBound(colID)

SaveAttachments colID(i)

Next

End If

End Sub

Private Sub SaveAttachments(ByVal strEntryID As String)

Const SAVE_PATH = " C:\Users\XXX\Documents \FF\"

Const SAVE_PATH2 = " C:\Users\XXXX\Documents\FN\"

Dim objFSO As Object

Dim objMsg As Object

Dim objAttach As Attachment

Dim FileName1 As String

Dim FileName2 As String

Dim n As Long

Dim letter As String

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objMsg = Application.Session.GetItemFromID(strEntryID)

If Not objMsg.Subject Like "*ファイルです*" Then Exit Sub

For Each objAttach In objMsg.Attachments

With objAttach

FileName1 = objAttach.FileName

FileName2 = ""

For n = 1 To Len(FileName1)

letter = Mid(FileName1, n, 1)

If IsNumeric(letter) = True Then

FileName2 = FileName2 & letter

End If

Next

FileName1 = SAVE_PATH & FileName1

FileName2 = SAVE_PATH2 & FileName2 & ".pdf"

.SaveAsFile FileName1

.SaveAsFile FileName2

End With

Next

Set objMsg = Nothing

Set objFSO = Nothing

End Sub

OUTLOOK研究所さんのサンプルとの主な違いは、保存するファイルが2つあることと、ファイル名は番号と日付がついており、重複することは原則ないため、同じファイル名が既にあった場合、上書きしないように改めて番号をふる、という部分を削ったこと。

一応、マクロとしては望んだとおりに動いてくれている。良かった、よかった。