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

通过Excel中的联系人列表中的电子邮件ID获取名称

2 个答案: