受信したアカウントごとのフォルダに添付ファイルを保存するマクロ


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


非常に便利なので、利用させていただいております。
FAXをメール添付させるサービスを使っているので、特定のPCでそのメールを自動受信させ、
このマクロで、フォルダに保存しています。
その後、保存したフォルダの内容を印刷することをVBSで行っています。
そこで、お聞きしたいのですが、別のアカウントで受信したメールの添付ファイルを
別フォルダに保存する方法はありますか。
件名や本文などに違いはありません。違いはアカウント名だけです。
よろしくお願いします。


Outlook 2007 以降であれば受信したアカウントの情報を取得することができます。以下は、受信したアカウント名のサブフォルダに添付ファイルを保存するマクロです。すでに受信したメールの添付ファイルを自動保存するマクロが登録されている場合は、SaveAttachments をこちらの記事のものと入れ替えてください。
なお、残念ながら Outlook 2003 以前ではアカウント名の取得はできません。

' ここをトリプルクリックでマクロ全体を選択できます。
' メール受信時に発生するイベント
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\"
    Const PidLidInternetAccountName = "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8580001E"
    Dim objFSO As Object ' FileSystemObject
    Dim objMsg As Object
    Dim objAttach As Attachment
    Dim strFileName As String
    Dim strAccount As String
    Dim c As Integer: c = 1
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objMsg = Application.Session.GetItemFromID(strEntryID)
    ' ここで条件指定
    strAccount = objMsg.PropertyAccessor.GetProperty(PidLidInternetAccountName)
    ' アカウント名が取得できたらサブフォルダを作成
    If strAccount <> "" Then
        If Not objFSO.FolderExists(SAVE_PATH & "\" & strAccount) Then
            objFSO.CreateFolder SAVE_PATH & "\" & strAccount
        End If
        strAccount = strAccount & "\"
    End If
    '
    For Each objAttach In objMsg.Attachments
        With objAttach
            strFileName = SAVE_PATH & strAccount & 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

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

広告

受信したアカウントごとのフォルダに添付ファイルを保存するマクロ」への4件のフィードバック

  1. マクロの有用さに驚いています。すみません。メールを受信した(もしくは差出人が送信をした)日付ごとにフォルダを自動作成しそこにメールの添付ファイルを自動的に保存したいのですが、どうすればよいでしょうか。

  2. To 名前なしさん受信した日付ごとのフォルダを作成するという場合、上記のコードの strAccount = objMsg.PropertyAccessor.GetProperty(PidLidInternetAccountName) を以下の通り置き換えます。strAccount = Replace(FormatDateTime(objMsg.ReceivedTime,vbShortDate),"/","-")

  3. 返信ありがとうございます。コメントが大変遅くなってしまいすみません。解決することができました。ありがとうございました。

  4. 返信が大変遅くなり、すみません。アカウントの情報は、2007以降でないと取得できないのですね。現在、2003を使用しているため、せっかくのマクロを使えませんでした。結局、アカウントごとに必ず、件名と本文にユニークなキーワードを入れてもらい、条件指定をして、保存先フォルダを振り分けました。現状はこれで問題がなさそうです。ありがとうございました。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中