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

Question

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

如何做到这一点？

Answer 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

Answer 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