添付ファイルを削除して転送するマクロ


コメントにて以下のご要望をいただきました。


お世話になります。outlook2013で
「添付ファイルのあるメールの受信時に、添付ファイルを消して、その添付ファイルのないメールを任意のアドレスに転送する」マクロを作成していただけませんでしょうか?
注文が多いですが何卒よろしくお願いします。



添付ファイルを削除するにはアイテムの Attachments の Remove メソッドを使用します。
これを使って転送メールからすべての添付ファイルを削除すれば実現は可能ですが、ただ単に削除してしまうと HTML メールの埋め込み画像まで削除してしまいます。
そのため、以前紹介した添付ファイルが埋め込み画像かどうか判断する方法を使用し、埋め込み画像ではないファイルだけ削除して転送するようにしました。
マクロは以下の通りです。
ForwardWithoutAttach を自動仕分けのルールのスクリプトとして指定してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Public Sub ForwardWithoutAttach(objMail As MailItem)
    Const FORWARD_TO_ADDR = "forward@example.com"
    Dim i As Integer
    Dim fwdMail As MailItem
    '
    Set fwdMail = objMail.Forward
    fwdMail.To = FORWARD_TO_ADDR
    '
    For i = fwdMail.Attachments.Count To 1 Step -1
        If Not IsAttachEmbedded(fwdMail.Attachments(i)) Then
            fwdMail.Attachments.Remove i
        End If
    Next
    '
    fwdMail.Send
End Sub
'
Private Function IsAttachEmbedded(objAttach As Attachment)
    Const PR_ATTACH_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim iAttFlags As Integer
    Dim strAttCID As String
    ' 既定は通常の添付ファイル
    IsAttachEmbedded = False
    ' フラグが 0 以外なら埋め込み画像
    iAttFlags = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_FLAGS)
    If iAttFlags <> 0 Then
        IsAttachEmbedded = True
    End If
    ' Content ID があれば埋め込み画像
    strAttCID = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
    If strAttCID <> "" Then
        IsAttachEmbedded = True
    End If
    ' OLE オブジェクトなら埋め込み画像
    If objAttach.Type = olOLE Then
        IsAttachEmbedded = True
    End If
End Function

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

添付ファイルを削除して転送するマクロ」への1件のフィードバック

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中