社外のアドレスを宛先に含む場合のみ BCC を追加するマクロ


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


Outlookで常に特定のメールアドレスを[Bcc:]に入れて送信するマクロを組みたいのですが、できれば加えて宛先が社外のメールのみという指定ができればと思っております。
  全送信メールに対して設定するマクロについては、検索で見つけることができ、設定して試してみたところ問題なく動作しました。
ただ、「社外メールのみ」という部分を検索で指定すると、自分の検索方法が悪いのかもしれないのですが、見つけることができず、こちらでコメントさせて頂いた次第です。当方、マクロなど素人につき、お教えいただけたら幸いです。どうぞ、よろしくお願い致します。

使用環境
Windows10
  office2016


宛先が社外のメールかどうかを判断するには、宛先のアドレスのドメインを確認する必要があります。
メールアドレスは Recipient オブジェクトの Address プロパティで確認できるのですが、Outlook.com に接続しているような場合は Address プロパティでは SMTP アドレスが取得できないこともあります。
そのため、アドレス取得のロジックは Exchange 環境下で組織外のアドレスに送信する際に警告を表示するマクロのものを流用しています。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
     Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
     Const BCC_ADDR = "bcc@example.com" ' BCC として追加するアドレス
     Dim objRec As Recipient
     Dim strSMTPAddr As String
     Dim bExternal As Boolean
     Dim recBcc As Recipient
     ' 組織外の受信者が存在するかどうかの確認
     bExternal = False
     For Each objRec In Item.Recipients
         strSMTPAddr = GetSMTPAddr(objRec)
         If Not strSMTPAddr Like MY_DOMAIN Then
             bExternal = True
             Exit For
         End If
     Next
     ' 組織外の受信者が複数含まれていた場合は BCC を追加
     If bExternal Then
         Set recBcc = Item.Recipients.Add(BCC_ADDR)
         recBcc.Type = olBCC
         recBcc.Resolve
         Item.Save
     End If
End Sub
' SMTP アドレス取得関数
Private Function GetSMTPAddr(objRec As Recipient)
     Const PR_ORIGINAL_DISPLAY_NAME = "http:" & "//schemas.microsoft.com/mapi/proptag/0x3a13001e"
     Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
     Dim strSMTPAddr As String
     If objRec.AddressEntry.Type = "SMTP" Then
         strSMTPAddr = objRec.Address
     Else ' Exchange 対応
         If objRec.AddressEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
             strSMTPAddr = objRec.AddressEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
         Else
             strSMTPAddr = objRec.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
         End If
     End If
     GetSMTPAddr = strSMTPAddr
End Function

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Google+ フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中