从 Excel 中的联系人列表中按电子邮件 ID 获取姓名答案

【问题标题】：Fetching names by email id from Contact List in Excel从 Excel 中的联系人列表中按电子邮件 ID 获取姓名
【发布时间】：2012-11-21 07:24:08
【问题描述】：

我有一个 Excel 表格中的电子邮件 ID 列表，我想使用 VBA 脚本从 Outlook 联系人列表中获取他们的姓名。我在网上搜索过，但没有找到适合我的东西？

如何做到这一点？

【问题讨论】：

我发布的解决方案是从 Outlook 联系人列表中获取地址，而不是从全局地址列表中获取地址。你确定这是你想要的吗？
修改了问题...

标签： vba excel outlook

【解决方案1】：

以下有效。下面的代码获取与 "abc@xyz.com" 对应的名称你可以使用一个数组并比较我认为。不知道有没有更好的办法。

Public Sub getName()
  Dim contact As Object
  Dim AL As Object
    Dim outApp As Object
    Set outApp = CreateObject("Outlook.Application")
    'Logon
    outApp.Session.Logon

    'Get contact from Outlook
    Set AL = outApp.Session.GetDefaultFolder(10)
        For Each contact In AL.Items
            'iterate through each contact and compare
            If contact.Email1Address = "abc@xyz.com" Then
                Debug.Print (contact.FullName)
            End If
        Next contact
    outApp.Session.Logoff
    outApp.Quit

    'cleanup
    Set outApp = Nothing
    Set GAL = Nothing
End Sub

【讨论】：

这不是全局地址列表 (GAL) - 它是用户联系人列表。
@brettdj 是的。这是本地联系人列表。我不认为这是OP想要的。一旦他不接受，我将删除它。
不需要。我修改了问题。如果我需要，会再次询问 GAL 问题。

【解决方案2】：

下面的代码会有帮助吗？
正在处理：My Name <My.Name@MyCompany.co.uk>、My Name、MyName@Gmail.Com

Sub Test()

    Dim rEmails As Range
    Dim rEmail As Range
    Dim oOL As Object

    Set oOL = CreateObject("Outlook.Application")
    Set rEmails = Sheet1.Range("A1:A3")

    For Each rEmail In rEmails
        rEmail.Offset(, 1) = ResolveDisplayNameToSMTP(rEmail.Value, oOL)
    Next rEmail

End Sub

' Author: Sue Mosher - updated by D.Bartrup-Cook to work in Excel late binding.
Public Function ResolveDisplayNameToSMTP(sFromName, OLApp As Object) As String


    Select Case Val(OLApp.Version)
        Case 11 'Outlook 2003

            Dim oSess As Object
            Dim oCon As Object
            Dim sKey As String
            Dim sRet As String

            Set oCon = OLApp.CreateItem(2) 'olContactItem

            Set oSess = OLApp.GetNameSpace("MAPI")
            oSess.Logon "", "", False, False
            oCon.Email1Address = sFromName
            sKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
            oCon.FullName = sKey
            oCon.Save

            sRet = Trim(Replace(Replace(Replace(oCon.email1displayname, "(", ""), ")", ""), sKey, ""))
            oCon.Delete
            Set oCon = Nothing

            Set oCon = oSess.GetDefaultFolder(3).Items.Find("[Subject]=" & sKey) '3 = 'olFolderDeletedItems
            If Not oCon Is Nothing Then oCon.Delete

            ResolveDisplayNameToSMTP = sRet

        Case 14 'Outlook 2010

            Dim oRecip As Object 'Outlook.Recipient
            Dim oEU As Object 'Outlook.ExchangeUser
            Dim oEDL As Object 'Outlook.ExchangeDistributionList

            Set oRecip = OLApp.Session.CreateRecipient(sFromName)
            oRecip.Resolve
            If oRecip.Resolved Then
                Select Case oRecip.AddressEntry.AddressEntryUserType
                    Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                        Set oEU = oRecip.AddressEntry.GetExchangeUser
                        If Not (oEU Is Nothing) Then
                            ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                        End If
                    Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                            ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
                End Select
            Else
                ResolveDisplayNameToSMTP = sFromName
            End If
        Case Else
            'Name not resolved so return sFromName.
            ResolveDisplayNameToSMTP = sFromName
    End Select
End Function

【讨论】：

该死 - 刚刚注意到原始发布日期。我们如何避免旧帖子出现在列表顶部？