从 Outlook GAL 获取电子邮件地址？答案

【问题标题】：Get email address from Outlook GAL?从 Outlook GAL 获取电子邮件地址？
【发布时间】：2022-01-24 22:25:43
【问题描述】：

我有以下代码尝试从 Outlook 中获取 GAL，并将此人的姓名 + 他们的电子邮件地址放入另一张表中。

它获取名字（但不是电子邮件地址）然后停止。如果我注释掉Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress，它会成功列出所有名称，这表明我可能使用了错误的类型来获取电子邮件地址。 VBA 没有智能感知，所以我不知道用什么代替！

Private Sub UpdateEmails()

' Need to add reference to Outlook
' Adds addresses to existing Sheet called Emails and
' defines name NamesAndEmailAddresses containing this list

On Error GoTo error

Dim objOutlook As Outlook.Application
Dim objAddressList As Outlook.AddressList
Dim objAddressEntry As Outlook.AddressEntry
Dim intCounter As Integer

Application.ScreenUpdating = False

' Setup connection to Outlook application
Set objOutlook = CreateObject("Outlook.Application")
Set objAddressList = objOutlook.Session.AddressLists("Global Address List")

Application.EnableEvents = False

' Clear existing list
Sheets("Emails").Range("A:A").Clear

'Step through each contact and list each that has an email address
For Each objAddressEntry In objAddressList.AddressEntries
    If objAddressEntry.Address <> "" Then
        intCounter = intCounter + 1
        Application.StatusBar = "Processing no. " & intCounter & " ... " & objAddressEntry.Address
        Sheets("Emails").Cells(intCounter, 1) = objAddressEntry.Name
        Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.PrimarySmtpAddress
        DoEvents
    End If
Next objAddressEntry

' Define range called "NamesAndEmailAddresses" to the list of emails
Sheets("Emails").Cells(1, 2).Resize(intCounter, 1).Name = "NamesAndEmailAddresses"
error:
Set objOutlook = Nothing
Application.StatusBar = False

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

【问题讨论】：

标签： excel vba outlook

【解决方案1】：

看MSDN上的AddressEntry Object (Outlook)页面，你要的属性是AddressEntry.Address

Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.Address

此外，如果您从工具 > 参考...* 提前绑定 Outlook，那么您将获得 Intellisense。或者，您可以在 Outlook 中按 [Alt]+[F11] 并在那里使用 Intellisense。

{EDIT} 因为这是提供 Exchange Server 上的路径而不是完整的电子邮件地址 如果联系人在 Exchange 地址列表中，则您可以使用 .GetExchangeUser.PrimarySmtpAddress 获取 Exchange Server 上用户的主要 Smtp 地址。（对于您帐户中的本地联系人，请改用GetContact.Email1Address）

Sheets("Emails").Cells(intCounter, 2) = objAddressEntry.GetExchangeuser.PrimarySmtpAddress

【讨论】：

我已经尝试过Address，但它返回的结果如下：/o=domain/ou=First Administrative Group/cn=Recipients/cn=name 而不是电子邮件地址
@MrJF 因为这只是带回 Exchange 用户而不是完整的域路径，您可以使用 .GetExchangeUser。有时你会从.Address 得到类似“smtp:forename.surname@domain.com”的东西，这取决于它的设置方式。答案已更新
对不起 - 这也没有奏效。当我使用.GetExchangeUser 时，它会阻止代码再次运行，就像我之前有 smtp 地址一样。

【解决方案2】：

要获取或检查某人是否在 GAL 上拥有电子邮件地址：（见solution）

Sub testGetEmail()
Debug.Print GetEmailName("Dupont", "Alain")
End Sub

Function GetEmailName(FirstName As String, SecondName As String) As String
Dim oExUser As Outlook.ExchangeUser
Dim oAL As Outlook.AddressList

    Set oAL = Application.Session.AddressLists.Item(["Global Address List"])
    FullName = FirstName & ", " & SecondName
    Set oExUser = oAL.AddressEntries.Item([FullName]).GetExchangeUser
    GetEmailName = oExUser.PrimarySmtpAddress
End Function

【讨论】：