メール送信時に配布グループを展開してアドレスを確認し、社外のアドレスへの送信で警告を表示するマクロ


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


はじめまして。
初心者ゆえ色々と参考にさせて頂き助かっております。
単純な質問で申し訳ありません。
Exchange環境でOutlook2016でメール送信時にメーリングリスト(グローバル配布先グループ)の
メンバーのSMTPアドレスを展開してメッセージ表示させるようにしたいのですが、
どうすれば良いのでしょうか。
グローバルの配布先グループに社外アドレスが含まれているものもあり、警告を出したいと
考えています。
ご教授のほど、宜しくお願い致します。


Exchange の配布グループについては Recipient オブジェクトの AddressEntry プロパティの GetExchangeDistributionList メソッドで ExchangeDistributionList オブジェクトとして取得可能です。
また、グループのメンバーは  ExchangeDistributionList オブジェクトの GetExchangeDistributionListMembers メソッドで AddressEntries として取得可能です。
これらのオブジェクトを使用してメンバーを展開することができます。
また、以前 Outlook の連絡先グループを展開するマクロについても「連絡先グループのメンバーを展開してメールアドレスを取得するマクロ」として作成していましたので、こちらの機能も追加しました。

マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。

'
Const MY_DOMAIN = "*@example.com" ' 自組織のドメイン名を指定。@ の前に * を付ける
Const REC_DELIMITER = "; " ' 複数受信者を表示する際の区切り文字
'
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRec As Recipient
    Dim strSMTPAddr As String
    Dim strOut As String
    Dim iRet As Integer
    ' 組織外の受信者が存在するかどうかの確認
    bExternal = False
    strOut = ""
    For Each objRec In Item.Recipients
        ' 受信者の種類で判断
        Select Case objRec.AddressEntry.AddressEntryUserType
            Case olExchangeDistributionListAddressEntry
                ' Exchange の配布グループの展開
                ExpandExDistList objRec.AddressEntry, strOut
            Case olOutlookDistributionListAddressEntry
                ' Outlook の連絡先グループの展開
                ExpandOlContactGroup objRec, strOut
            Case Else
                ' グループではない受信者
                strSMTPAddr = GetSMTPAddr(objRec.AddressEntry)
                If Not strSMTPAddr Like MY_DOMAIN Then
                    strOut = strOut & strSMTPAddr & REC_DELIMITER
                End If
        End Select
    Next
    ' 組織外の受信者が含まれていた場合の処理
    If strOut <> "" Then
        iRet = MsgBox("あて先に組織外のドメインのメールアドレスが含まれています。送信しますか?" & _
            vbCrLf & "外部ドメイン宛: " & strOut, vbYesNo, "送信確認")
        Select Case iRet
            Case vbYes
                ' 送信日時を 1 分後に設定
                Item.DeferredDeliveryTime = DateAdd("n", 1, Now)
                Cancel = False ' 念のため
            Case vbNo
                Cancel = True
        End Select
    End If
End Sub
' SMTP アドレス取得関数
Private Function GetSMTPAddr(objAddrEntry As AddressEntry)
    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 objAddrEntry.Type = "SMTP" Then
        strSMTPAddr = objAddrEntry.Address
    Else ' Exchange 対応
        If objAddrEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
            strSMTPAddr = objAddrEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
        Else
            strSMTPAddr = objAddrEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
    End If
    GetSMTPAddr = strSMTPAddr
End Function
' Exchange 配布グループを展開するサブ プロシージャ
Private Sub ExpandExDistList(objExchDL As AddressEntry, ByRef strOut As String, Optional ByVal strExpanded As String = "")
    Const PR_SMTP_ADDRESS = "http:" & "//schemas.microsoft.com/mapi/proptag/0x39fe001e"
    Dim objExDistList As ExchangeDistributionList
    Dim colMembers As AddressEntries
    Dim objMember As AddressEntry
    Dim strSMTPAddr As String
    '
    If InStr(strExpanded, objExchDL.ID & ";") > 0 Then
        Exit Sub    ' 展開済みのグループは展開しない
    End If
    strExpanded = strExpanded & objExchDL.ID & ";"
    ' Exchange 配布グループ オブジェクトを取得
    Set objExchDL = Session.CreateRecipient(objExchDL.Address)
    objExchDL.Resolve
    Set objExDistList = objExchDL.GetExchangeDistributionList
    ' 配布グループのメンバーを取得
    Set colMembers = objExDistList.GetExchangeDistributionListMembers
    ' メンバーごとに処理
    For Each objMember In colMembers
        If objMember.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
            ' メンバーが配布グループなら再帰して展開
            ExpandExDistList objMember, strOut, strExpanded
        Else
            ' メンバーの SMTP アドレスを取得
            strSMTPAddr = GetSMTPAddr(objMember)
            ' メンバーのアドレスが社外なら社外リストに追加
            If Not strSMTPAddr Like MY_DOMAIN Then
                strOut = strOut & strSMTPAddr & REC_DELIMITER
            End If
        End If
    Next
End Sub
' Outlook の連絡先グループを展開するサブ プロシージャ
Private Sub ExpandOlContactGroup(objRec As Recipient, ByRef strOut As String, Optional ByVal strExpanded As String = "")
    Dim strCbLo As String
    Dim strCbHi As String
    Dim iCb As Integer
    Dim strEntryID As String
    Dim distList As DistListItem
    Dim objMember As Recipient
    Dim strSMTPAddr As String
    Dim i
    '
    If strExpanded = "" Then ' 展開済みのグループがない = トップのグループ
        ' 65 文字目からの 4 文字がエントリー ID の長さ
        strCbLo = Mid(objRec.AddressEntry.ID, 65, 2)
        strCbHi = Mid(objRec.AddressEntry.ID, 67, 2)
        iCb = Val("&H" & strCbHi & strCbLo)
        ' 73 文字目からがアイテムのエントリー ID
        strEntryID = Mid(objRec.AddressEntry.ID, 73, iCb * 2)
        Set distList = Session.GetItemFromID(strEntryID)
    Else ' 入れ子になっているグループの場合は 43 文字目からがアイテムのエントリー ID
        strEntryID = Mid(objRec.AddressEntry.ID, 43)
    End If
    '
    If InStr(strExpanded, strEntryID) > 0 Then
        Exit Sub      ' 展開済みのグループは展開しない
    End If
    strExpanded = strExpanded & strEntryID & ";"
    ' 連絡先グループ オブジェクトを取得
    Set distList = Session.GetItemFromID(strEntryID)
    ' メンバーごとに処理
    For i = 1 To distList.MemberCount
        Set objMember = distList.GetMember(i)
        If objMember.Address = "Unknown" Then
            ' メンバーが配布グループなら再帰して展開
            ExpandOlContactGroup objMember, strOut, strExpanded
        Else
            ' メンバーの SMTP アドレスを取得
            strSMTPAddr = GetSMTPAddr(objMember.AddressEntry)
            ' メンバーのアドレスが社外なら社外リストに追加
            If Not objMember.Address Like MY_DOMAIN Then
                strOut = strOut & objMember.Address & REC_DELIMITER
            End If
        End If
    Next
End Sub

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

メール送信時に配布グループを展開してアドレスを確認し、社外のアドレスへの送信で警告を表示するマクロ」への2件のフィードバック

  1. 有用なコード/アイデアを多数公開していただき、ありがたく利用させていただいております。
    メール誤送信の防止の為、送信メールの宛先等を判別して警告するマクロを自社開発し利用しておりますが、判別の高度化が必要となりこの記事にあるコードが参考になりました。

    配布グループのメンバ展開が上手く機能しないケースがあり、問題を解消する為には、別記事になっている「固定アドレスを追加して返信、転送をするマクロ(2019年8月17日)」に掲載されているコードの一部ロジック(受信者の表示名をアドレス帳のもので置き換えるマクロ)を利用したコードで、Outlook標準の「返信」「全員への返信」を置き換える必要がありました。

    問題のケースは、返信メールの元となる受信メールが「配布グループを差出人として送信されたもの」に返信する場合に発生しました。この元メールに返信すると、返信メールの宛先に配布グループのアドレスがセットされますが、この宛先のオブジェクトの内部構造が通常の配布グループのものにならないのが原因のようでした。「所有者として送信」権限を使って送信された場合でも「代理人として送信」の場合でもどちらの場合でも問題が起こりました。

    使用しているOutlookは非サブスクリプションのOffice2016です。このOutlookに起因する問題なのかどうなのか環境を違えて試験することまではできておりません。

    • 確かに配布グループが差出人になっているメールに返信をすると、そのグループの展開の際にエラーになりますね。
      グループの名前解決をやり直して展開するようマクロを修正しました。

outlooklab にコメントする コメントをキャンセル

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

WordPress.com ロゴ

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

Google フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中