受信したメールの添付ファイルを自動保存するマクロ

これまで、MAPI や Outlook オブジェクト モデルなど基本的な部分の説明をしてきましたが、そろそろ実用的な記事も書かないと飽きられてしまうかもしれませんね。そこで、今回は Outlook に関する掲示板などでよく話題に出ると思われる、受信したメールの添付ファイルを自動保存するマクロについて書きたいと思います。

たとえば、毎日あるいは毎週必ず特定の人やシステムからレポートが添付ファイルとして送信されてくる、というようなケースがあります。それを自動保存するというような機能は残念ながら Outlook にはないのですが、マクロを使えばそのようなことが実現できるのです。

以下は、受信したメールの添付ファイルをすべて C:\Attachments というフォルダに保存するというマクロです。

---

' メール受信時に発生するイベント
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:\attachments\"
    Dim objFSO As Object ' FileSystemObject
    Dim objMsg As Object
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer: c = 1
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objMsg = Application.Session.GetItemFromID(strEntryID)
'
' ここで条件指定
'
    For Each objAttach In objMsg.Attachments
        With objAttach
          
            strFileName = SAVE_PATH & objAttach.FileName
           
            While objFSO.FileExists(strFileName)
                strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                    & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                c = c + 1
            Wend
           
            .SaveAsFile strFileName
        End With
    Next
    Set objMsg = Nothing
    Set objFSO = Nothing
End Sub


---

では、上記のマクロについて説明しましょう。
まず、メールを受信した際に何らかの処理を行うという場合、Outlook では Application_NewMailEx というイベントを使用します。このイベントが呼ばれる際に EntryIDCollection に受信したメールのエントリ ID が文字列として渡されますが、複数のメールを同時に受信した場合には、「,」で区切って複数のエントリ ID が渡されます。そこで上記の Application_NewMailEx では EntryIDCollection に「,」が含まれる場合には Split 関数で分割し、それぞれのエントリ ID について処理するという記述をしています。

そして、実際に添付ファイルの処理が行われるのは SaveAttachments です。最初の行の Const SAVE_PATH = で保存するフォルダを指定していますので、C:\Attachments 以外のフォルダに添付ファイルを保存したい場合はこの記述を変更してください。なお、変更の際にはフォルダ名の最後に \ をつけてください。
受信したメールを取得するには、Application.Session.GetItemFromID メソッドを使用します。GetItemFromID では引数としてメールの EntryID を指定しますが、これは Application_NewMailEx で EntryIDCollection として取得したものになります。
次に、取得したメールの添付ファイルにアクセスするには、Attachments コレクションを使用します。For Each で Attachments コレクションから Attachment オブジェクトを取得し、そのオブジェクトの SaveAsFile メソッドにより添付ファイルを保存します。
ここで注意しなければならない点は SaveAsFile メソッドは保存先にすでに同じ名前のファイルがあった場合に上書きしてしまうということです。
上記のマクロでは、While … Wend でファイルの保存先に同名のファイルがあるかどうかを FileSystemObject オブジェクトの FileExists メソッドにより確認し、存在した場合にはファイル名に -1、-2 というように数字をつけて上書きが発生しないようなファイル名にしています。

なお、このマクロの例では受信したすべてのメールの添付ファイルを保存しますが、特定の条件の場合だけ保存したということもあるでしょう。
その場合、「' ここで条件指定」のところに保存する条件を指定し、条件に合わない場合 Exit Sub で保存処理を行わずに終了するという記述を行います。
たとえば、「Report」という単語を件名に含むメールの添付ファイルだけを保存したいという場合は、以下のように記述します。

    If Not objMsg.Subject Like "*Report*" Then Exit Sub

このほか、メールの件名や日付をファイル名や保存フォルダに使いたいというような要望もあるかもしれませんが、マクロが複雑になっていくのでこの辺にしておきます。

もし、こんなマクロがあったら便利なのに、と思うようなものがあればコメントに書き込んでください。需要がありそうなものであれば対応します。

2009/12/22 追記:

Application_NewMailEx イベントはメッセージを Outlook で受信したタイミングで発生するイベントですが、Exchange サーバー環境で利用している場合、Outlook を起動していない間にサーバーで受信されたメッセージに対してはこのイベントが発生しません。

サーバーで受信されたメッセージに対しても添付ファイルの保存を行うには、自動仕分けのクライアント ルールで実行できるマクロを作成します。
具体的な手順は以下の通りです。

1. 下記のようなマクロを記述します。このマクロは上記の Application_NewMailEx の代わりとなるものです。
   

   ' 添付ファイルの保存を行うサブ プロシージャ
Public Sub SaveAttachments(objMsg As MailItem)
    Const SAVE_PATH = "C:\attachments\"
    Dim objFSO As Object ' FileSystemObject
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim c As Integer: c = 1
'   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
'
    For Each objAttach In objMsg.Attachments
        With objAttach
           '
            strFileName = SAVE_PATH & objAttach.FileName
            '
            While objFSO.FileExists(strFileName)
                strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                    & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                c = c + 1
            Wend
            '
            .SaveAsFile strFileName
        End With
    Next
    Set objMsg = Nothing
    Set objFSO = Nothing
End Sub


2. 新しい自動仕分けのルールを作成します。
3. 条件にマクロを実行したいメールについての任意の条件を設定します。すべてのメールで実行する場合には条件を指定する必要はありません。
4. メッセージに対する処理で [スクリプトを実行する] をオンにし、[スクリプト] をクリックします。
5. [スクリプトの選択] ダイアログで SaveAttachments を選択し、[OK] をクリックします。
6. [完了] をクリックし、ルールの作成を終了します。

---

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