3

NameOutlook 2013 からグローバル アドレス一覧全体を取得し、値をE-mail AddressExcel シートに配置するための VBA コードがあります。

問題は、SMTP からのみ電子メール/ユーザーを返すことです (推測します)。

http://i.stack.imgur.com/YtPOm.jpg

この画像では、SMTP からのユーザーが黒で覆われ、外部ユーザーが赤で覆われていることがわかります。私のコード:

Sub tgr()

    Dim appOL As Object
    Dim oGAL As Object
    Dim oContact As Object
    Dim oUser As Object
    Dim arrUsers(1 To 75000, 1 To 2) As String
    Dim UserIndex As Long
    Dim i As Long

    Set appOL = CreateObject("Outlook.Application")

    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries

    For i = 1 To oGAL.Count
        Set oContact = oGAL.Item(i)
        If oContact.AddressEntryUserType = 0 Then
            Set oUser = oContact.GetExchangeUser
            If Len(oUser.lastname) > 0 Then
                UserIndex = UserIndex + 1
                arrUsers(UserIndex, 1) = oUser.Name
                arrUsers(UserIndex, 2) = oUser.PrimarySMTPAddress
            End If
        End If
    Next i

    appOL.Quit

    If UserIndex > 0 Then
        Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
    End If

    Set appOL = Nothing
    Set oGAL = Nothing
    Set oContact = Nothing
    Set oUser = Nothing
    Erase arrUsers

End Sub

それで、私は何か間違ったことをしていますか？

4

1 に答える 1

0

このドキュメントによると、外部ユーザーの場合、oContact.AddressEntryUserType値には (5) が含まれている必要があります。olExchangeRemoteUserAddressEntry

コードには、Exchange ユーザーを一覧表示するだけなので、メールが有効な PublicFolders、配布リストなどもスキップされます。

EDIT
名前と電子メールアドレスを抽出するより良い方法を見つけました (存在する場合):
参照:受信者の電子メールアドレスを取得する

Option Explicit

Sub tgr()
    Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Dim appOL As Object
    Dim oGAL As Object
    Dim arrUsers() As String
    Dim UserIndex As Long
    Dim i As Long
    Dim sEmail As String

    Set appOL = GetObject(, "Outlook.Application")
    If appOL Is Nothing Then Set appOL = CreateObject("Outlook.Application")

    Set oGAL = appOL.GetNameSpace("MAPI").AddressLists("Global Address List").AddressEntries
    Debug.Print oGAL.Parent.Name & " has " & oGAL.Count & " entries"
    ReDim arrUsers(1 To oGAL.Count, 1 To 2)
    On Error Resume Next
    For i = 1 To oGAL.Count
        With oGAL.Item(i)
            Application.StatusBar = "Processing GAL entry #" & i & " (" & .Name & ")"
            sEmail = "" ' Not all entries has email address
            sEmail = .PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
            If Len(sEmail) = 0 Then Debug.Print "No Email address configured for " & .Name & " (#" & i & ")"
            UserIndex = UserIndex + 1
            arrUsers(UserIndex, 1) = .Name
            arrUsers(UserIndex, 2) = sEmail
        End With
    Next
    On Error GoTo 0
    Application.StatusBar = False
    appOL.Quit

    If UserIndex > 0 Then
        Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
    End If

    Set appOL = Nothing
    Set oGAL = Nothing
    Erase arrUsers

End Sub
于 2015-10-07T05:06:54.413 に答える