組織外への送信の際にアドレスをすべて Bcc に移動するマクロ

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

---

今年から勤務先で社外宛メール送信には以下のようなルールが作られました。

To：自分のアドレス
CC：ブランク
BCC：送信したいアドレス全て

社外から来たメールを「全員に返信」した場合など、
手動でToからBCCに移さなければいけません。
ルール通りになっていないと送信エラーで戻ってくるような仕組みになっており、
慣れかもしれませんが、再送の手間が非常にタイムロスになっています。

To/CC/BCCに１つでも社外ドメインが含まれていたら
Toに自分のアドレス、その他にTo/CC/BCCに含まれていた
全ての宛先をBCCに入力（移動）して送信する、というマクロが
もし可能であれば是非教えていただけると助かります。

---

下記のようなマクロで実現可能です。
MY_DOMAIN と MY_ADDRESS の定義を適切に変更して使用してください。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
    Const MY_ADDRESS = "test@example.com" ' 自分のメールアドレス
    Dim objRec As Recipient
    Dim bOut As Boolean
    ' 組織外の受信者が存在するかどうかの確認
    bOut = False
    For Each objRec In Item.Recipients
        If objRec.AddressEntry.Type <> "EX" Then
            If Not objRec.Address Like MY_DOMAIN Then
                bOut = True
                Exit For
            End If
        End If
    Next
    ' 組織外の受信者が含まれていた場合の処理
    If bOut Then
        For Each objRec In Item.Recipients
            ' 全受信者を BCC に移動
            objRec.Type = olBCC
        Next
        ' 自分を To に指定
        Set objRec = Item.Recipients.Add(MY_ADDRESS)
        objRec.Type = olTo
        objRec.Resolve
    End If
End Sub


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