CODEWITHSUNDEEP
vbaexceloutlook
Bharat Sinha
Bharat Sinha

Reputation: 14363

Fetching names by email id from Contact List in Excel

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?

Upvotes: 2

Views: 2027

Answers (2)

Darren Bartrup-Cook
Darren Bartrup-Cook

Reputation: 19712

Will the code below help?
It's worked on: My Name <[email protected]>, My Name, [email protected]

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

Upvotes: 0

Anirudh Ramanathan
Anirudh Ramanathan

Reputation: 46728

The following works. The code below fetches the name corresponding to "[email protected]" 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 = "[email protected]" Then
                Debug.Print (contact.FullName)
            End If
        Next contact
    outApp.Session.Logoff
    outApp.Quit

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

Upvotes: 2

Related Questions