Fetching names by email id from Contact List in Excel - vba

Question

I have a list of email ids in an excel sheet and I would like to fetch their names from Outlook Contact List using VBA script. I have searched online but did not find something which is working for me?
How this can be done?

Answer 1

The following works. The code below fetches the name corresponding to "abc#xyz.com"
You could use an array and compare I think. Not sure if there is a better way.
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

Will the code below help?
It's worked on: 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