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


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


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

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

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

To/CC/BCCに1つでも社外ドメインが含まれていたら
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

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

組織外への送信の際にアドレスをすべて Bcc に移動するマクロ」への7件のフィードバック

  1. こんにちは。参考になるコードをありがとうございます。

    MY_DOMAINの指定ですが、同一組織内でサブドメイン(@aa.company.co.jp. @bb.company.co.jp…..)を使っている場合があるので、比較するときに「Like “*” & MY_DOMAIN」と後方一致になるようにして、MY_DOMAIN=”company.co.jp”と@をつけずに指定するとよいと思います。

    また、MY_DOMAINを定数ではなく配列変数として、Array関数でまとめて指定するようにすると、自組織と判断するアドレスを複数設定できます。

    Dim My_Domain As Variant
    My_Domain = Array(“company1.co.jp”, “company2.co.jp”, “jibun@home.ne.jp”)

    ‘ 組織外の受信者が存在するかどうかの確認
    Dim myItem As Variant
    Dim IntYes As Boolean
    bOut = False
    IntYes=False
    For Each objRec In Item.Recipients
    If objRec.AddressEntry.Type “EX” Then
    For Each myItem In My_Domain
    If objRec.Address Like “*” & myItem Then IntYes = True ‘配列MY_DOMAINの要素のどれかひとつでもヒットすればIntYesをTrueにする
    Next myItem
    If Not IntYes Then ‘IntYesがTrueでなければ外部アドレス
    bOut = True
    Exit For
    End If
    End If
    Next

    ところで、ひとつ教えてください。

    Recipient.AddressEntry.Typeでは、どういう場合にどのような値が得られるのですか。

    • ご意見ありがとうございます。参考にさせていただきます。
      なお、Recipient.AddressEntry.Type はアドレスの種類を表します。通常、インターネットメールの場合は “SMTP” となりますが、Microsoft Exchange サーバーを使用して組織内の宛先に送信した場合は “EX” となります。このチェックを行っているのは、Exchange の組織内のアドレス フォーマットにはドメインが含まれず、基本的に組織内のあて先であるため、チェックする意味がないからです。

      • AddressEntry.TypeでExchangeサーバのアドレスがチェックできるのですね。僕は同じことを『アドレスが「/O=」で始まる』という条件でチェックしていました。自分で考えたわけではなく、ネットで検索して見つけたものです。どちらが速いかはわかりませんが(普通のメールなら気になるほどの差は出ないと思います)、AddressEntry.Typeでチェックするほうがスマートですね。

        ところで、お示しいただいたマクロでは、アドレスに個人配布リストが含まれているとどうなりますか。個人配布リストは.addressが空白となっているようなので、おそらく””という外部アドレスと判断されて、誤動作するのではないかと思います。個人配布リストは.DisplayType=5という条件でチェックできるのですが、そのあとアドレス帳からその配布リストのメンバーを引っ張ってきてチェックする必要があって、面倒です。アドレスチェックをする前にすべての個人配布リストを展開(手動なら+ボタンを押す)してから行えばよいと思い、Outlookマクロで個人配布リストを展開することができないか調べてみたのですが、わかりません。もしご存知ならお教え下さい。

        Outllokにもマクロ記録機能があると楽なのですが。

      • このマクロでは個人用配布リストを考慮してませんでした。
        個人用配布リストの展開処理をマクロで実行することはできないので、マクロ内でのチェックの際にメンバーを連絡先から取得するしかありません。

  2. 投稿すると半角スペースがすべて削除されてしまうのですね。IFやForのインデントが全部飛んでしまったので、大変見にくくて申し訳ありません。

  3. #1の
    If objRec.AddressEntry.Type “EX” Then

    If objRec.AddressEntry.Type “EX” Then
    の間違いです。済みません。

    • Typeと”EX”の間に不等式<>の半角があるのですが、投稿すると消えてしまうようです。

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中