VBA-Excel How to find an email address from an exchange user in Outlook

Question

I have been trying to import a contact's email based on an input name. I am not that good at macro programming but have found a code that works. However it only works by looking up the information in the contacts folder and I need it to lookup a contact in the Global Address List give me back the email associated with that person. I have searched through other posts and they all want to take every contact from outlook and paste it to excel. I only want to search the Global Address List for a person based on the input name and have it return the email of that person.

Here is what I have:

Function GrabContactInfo(rRng As Range, iWanted As Integer) As String

Dim olA As Outlook.Application

Dim olNS As Namespace

Dim olAB As MAPIFolder

Dim lItem As Long   

Dim sNameWanted As String

Dim sRetValue As String

Set olA = New Outlook.Application
Set olNS = olA.GetNamespace("MAPI")
Set olAB = olNS.GetDefaultFolder(olFolderContacts)

Application.Volatile
sNameWanted = rRng.Value
sRetValue = "Not Found"

On Error Resume Next

For lItem = 1 To olAB.Items.Count
    With olAB.Items(lItem)
        If sNameWanted = .FullName Then
            Select Case iWanted
                Case 1
                    sRetValue = .CompanyName
                Case 2
                    sRetValue = .BusinessAddress
                Case 3
                    sRetValue = .BusinessAddressCity
                Case 4
                    sRetValue = .BusinessAddressState
                Case 5
                    sRetValue = .BusinessAddressPostalCode
                Case 6
                    sRetValue = .BusinessTelephoneNumber
                Case 7
                    sRetValue = .Email1Address
            End Select
        End If
    End With
Next lItem
olA.Quit
GrabContactInfo = sRetValue
End Function

Any information is helpful

Answer 1

Instead of looping through all the items in the Contacts folder, you can use Namespace.CreateRecipient / Recipient.Resolve to resolve a name to an instance of the Recipient object. You can then use AddressEntry.GetContact to resolve it to an instance of the ContactItem object or AddressEntry.GetExchangeUser to get an instance of the ExchangeUser object:

Set olA = New Outlook.Application
Set olNS = olA.GetNamespace("MAPI")
set olRecip = olNS.CreateRecipient("Dmitry Streblechenko")
olRecip.Resolve
set olAddrEntry = olRecip.AddressEntry
set olCont = olAddrEntry.GetContact
if not (olCont Is Nothing) Then
  'this is a contact
  'olCont is ContactItem object
  MsgBox olCont.FullName
Else
  set olExchUser = olAddrEntry.GetExchangeUser
  if not (olExchUser Is Nothing) Then
    'olExchUser is ExchangeUser object
    MsgBox olExchUser.StreetAddress
  End If
End If