連絡先グループのメンバーを展開してメールアドレスを取得するマクロ


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


Outlook2010を利用し、Exchange環境で、送信時のメールアドレスチェックを行っております。

複数の受信者に送信する際に警告を表示するマクロ」にある「GetNameAddr」にて
アドレスの取得を行っていますが、以下状況のアカウントのみ、アドレスが取得できません。

・「グループアドレス」を「連絡先」に追加した場合、「連絡先グループ」として
登録されるのですが、このグループのメールアドレスが取得できない

「AddressEntry.Type」が”MAPIPDL”となるためなのですが、この場合のメールアドレス取得方法を
教えていただけますでしょうか。

アドレス帳から任意のプロパティを取得する方法」を基に「PR_EMAIL_ADDRESS」などを
試しましたが、取得できません。

よろしくお願いします。



Outlook の連絡先グループ (個人用配布リスト) は、Outlook の連絡先フォルダーに作成されたアイテムであり、それ自体はメールアドレスを持ちません。
そして、メールを送信する際には Outlook 自身がグループのメンバーを展開し、宛先に追加して送信を行うという動作になります。
したがって、宛先チェックでアドレスを確認するというような場合、連絡先グループのメンバーを展開し、それぞれのメンバーのアドレスを取得する必要があります。
問題は、受信者のオブジェクトに連絡先グループがある場合、対応する連絡先グループ アイテム (DistListItem) を取得するメソッドが Outlook Object Model には用意されていないということです。

では、展開する方法がないのかというと、多少強引ですが方法はあります。

まず、受信者オブジェクトに連絡先グループがある場合、そのオブジェクトの AddressEntry.ID は以下の Web ページに記載されている CONTAB_ENTRYID という形式で格納されています。

https://msdn.microsoft.com/en-us/vstudio/bb820924

この形式のエントリー ID には、33 バイト目からの 4 バイトに連絡先フォルダーのアイテムのエントリー ID の長さが格納され、37 バイト目からアイテムのエントリー ID 自体が格納されています。

また、連絡先グループの中に入れ子で連絡先グループが含まれていた場合は、AddressEntry.ID は以下の Web ページに記載されている WrappedEntryId という形式で格納されています。

https://msdn.microsoft.com/en-us/library/ee200559(v=exchg.80).aspx

この形式のエントリー ID には 22 バイト目から連絡先グループ アイテムのエントリー ID が格納されています。

したがって、受信者の AddressEntry.ID から取得したアイテムのエントリー ID で GetItemFromID によりアイテムを取得することで、連絡先グループを展開することが可能です。

上記の方法により「複数の受信者に送信する際に警告を表示するマクロ」を連絡先グループに対応させると、以下のようなマクロになります。

' ここをトリプルクリックでマクロ全体を選択できます。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    WarnMultipleRecipients Item, Cancel
End Sub
'
Private Sub WarnMultipleRecipients(ByVal Item As Object, Cancel As Boolean)
    On Error Resume Next
    Dim oRec As Recipient
    Dim strTo As String
    Dim strCc As String
    Dim strBcc As String
    Dim strMsg As String
    ' 受信者が一人で連絡先グループでなければ何もしない
    If Item.Recipients.Count = 1 And _
      Item.Recipients(1).AddressEntry.AddressEntryUserType _
      <> olOutlookDistributionListAddressEntry Then
        Exit Sub
    End If
    ' 受信者確認
    For Each oRec In Item.Recipients
        Select Case oRec.Type
            Case olTo
                strTo = strTo & GetNameAddrEx(oRec)
            Case olCC
                strCc = strCc & GetNameAddrEx(oRec)
            Case olBCC
                strBcc = strBcc & GetNameAddrEx(oRec)
        End Select
    Next
    ' 確認ダイアログの表示
    strMsg = "下記の複数のアドレスに送信します。よろしいですか?" & vbCrLf
    If strTo <> "" Then
        strMsg = strMsg & "宛先: " & strTo & vbCrLf
    End If
    If strCc <> "" Then
        strMsg = strMsg & "Cc: " & strCc & vbCrLf
    End If
    If strBcc <> "" Then
        strMsg = strMsg & "Bcc: " & strBcc & vbCrLf
    End If
    If MsgBox(strMsg, vbYesNo, "宛先確認") = vbNo Then
        Cancel = True
    End If
End Sub
' 受信者オブジェクトから表示名とアドレスの文字列を取得する関数
Private Function GetNameAddrEx(oRec As Recipient) As String
    Const PR_ORIGINAL_DISPLAY_NAME = "http://schemas.microsoft.com/mapi/proptag/0x3a13001e"
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39fe001e"
    Dim strAddress As String
    If oRec.AddressEntry.Type = "SMTP" Then
        strAddress = oRec.Address
    ElseIf oRec.AddressEntry.AddressEntryUserType = olOutlookDistributionListAddressEntry Then
        Dim strExpanded As String
        strExpanded = ""
        GetNameAddrEx = ExpandGroup(oRec, strExpanded)
        Exit Function
    Else ' Exchange 対応
        If oRec.AddressEntry.AddressEntryUserType = olOutlookContactAddressEntry Then
            strAddress = oRec.AddressEntry.PropertyAccessor.GetProperty(PR_ORIGINAL_DISPLAY_NAME)
        Else
            strAddress = oRec.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
    End If
    ' 表示名に SMTP アドレスが含まれている場合はアドレスはつけない
    If InStr(oRec.Name, strAddress) > 0 Then
        GetNameAddrEx = oRec.Name & "; "
    Else
        GetNameAddrEx = oRec.Name & "<" & strAddress & ">" & "; "
    End If
End Function
' 連絡先グループを展開する関数
Private Function ExpandGroup(objRec As Recipient, strExpanded As String) 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 strNames 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 Function ' 展開済みのグループは展開しない
    Else
        strExpanded = strExpanded & strEntryID & ";"
    End If
    '
    Set distList = Session.GetItemFromID(strEntryID)
    strNames = ""
    For i = 1 To distList.MemberCount
        Set objMember = distList.GetMember(i)
        If objMember.Address = "Unknown" Then
            strNames = strNames & ExpandGroup(objMember, strExpanded)
        Else
            strNames = strNames & GetNameAddrEx(objMember)
        End If
    Next
    '
    ExpandGroup = strNames
End Function

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

コメントを残す

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

WordPress.com ロゴ

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

Twitter 画像

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

Facebook の写真

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

Google+ フォト

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

%s と連携中