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


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


はじめまして。
初心者ゆえ色々と参考にさせて頂き助かっております。
単純な質問で申し訳ありません。
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 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

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

広告

コメントを残す

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

WordPress.com ロゴ

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

Google フォト

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

Twitter 画像

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

Facebook の写真

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

%s と連携中