Lookup GAL from Outlook - excel

Question

I am building a tool which is required to look up the GAL in Outlook to find a certain employee and return their email address, their manager & manager's email address & finally their manager & manager's email address.
I found code and adjusted it to search for a person's name; however, if you have two Bob Smiths I require this to be more specific in its search, either by email address or by alias.
Any code I found creates an array with all users in the exchange server; however, with millions of employee records this takes a large amount of time and this would run once per week to update the information.
Is there a way to search ideally by alias or secondly by SMTP email address?
I found versions of the code and I modified them to suit my requirements but still unable to find by alias or email address. If I do this manually I can click on advance search and type the alias or I click on "more columns" and search the alias and the correct result appears.
Can I define "More Columns" in the VBA code?
Dim myolApp As Outlook.Application
Dim myNameSpace As Namespace
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim AliasName As String
Dim i As Integer, r As Integer
Dim c As Range
Dim EndRow As Integer, n As Integer
Dim exchUser As Outlook.ExchangeUser
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
Set myAddrList = myNameSpace.AddressLists("Global Address List")
Dim FullName As String, LastName As String, FirstName As String
Dim LDAP As String, PhoneNum As String
Dim StartRow As Integer
EndRow = Cells(Rows.Count, 1).End(xlUp).Row
StartRow = 2
For Each c In Range("I" & StartRow & ":I" & CStr(EndRow))
AliasName = LCase(Trim(c))
c = AliasName
Set myAddrEntry = myAddrList.AddressEntries(AliasName)
Set exchUser = myAddrEntry.GetExchangeUser
If Not exchUser Is Nothing Then
c.Offset(0, 1) = exchUser.FirstName
c.Offset(0, 2) = exchUser.LastName
c.Offset(0, 3) = exchUser.Alias
c.Offset(0, 4) = exchUser.PrimarySmtpAddress
c.Offset(0, 5) = exchUser.Manager
'etc...
End If
Next c

Answer 1

Have you checked the CreateRecipient namespace? https://learn.microsoft.com/en-us/office/vba/api/outlook.namespace.createrecipient
You could try creating a recipient object passing the alias to the CreateRecipient method:
Set myNamespace = Application.GetNamespace("MAPI")
Set recip = myNamespace.CreateRecipient("YourAlias")
recip.Resolve
You should of course check if your recipient was properly resolved by checking the resolved property:
If recip.Resolved Then
'Do something
After you got your recipient you can create an Exchange User from it using the GetExchangeUser method from the AdressEntry property in your recipient object.
Set exchUser = recip.AddressEntry.GetExchangeUser
Debug.Print exchUser.PrimarySmtpAddress
And I'm sure you can work it out from there!

Answer 2

I have been able to find a work around solution with the following function.
Function GetName(strAcc As String) As Variant
Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.Recipient
'Dim strAcc As String
Dim maxTries As Long
Dim errCount As Long
Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")
Set lappRecipient = lappNamespace.CreateRecipient(strAcc)
maxTries = 2000
On Error GoTo errorResume
Retry:
DoEvents
' For testing error logic. No error with my Excel 2013 Outlook 2013 setup.
' Should normally be commented out
'Err.Raise 287
lappRecipient.Resolve
On Error GoTo 0
Set olAddrEntry = lappRecipient.AddressEntry
If lappRecipient.Resolved Then
Set olexchuser = olAddrEntry.GetExchangeUser
GetName = olexchuser.Name
Else
GetName = "Unable To Validate LDAP"
End If
ExitRoutine:
Set lappOutlook = Nothing
Set lappNamespace = Nothing
Set lappRecipient = Nothing
Exit Function
errorResume:
errCount = errCount + 1
' Try until Outlook responds
If errCount > maxTries Then
' Check if Outlook is there and Resolve is the issue
lappNamespace.GetDefaultFolder(olFolderInbox).Display
GoTo ExitRoutine
End If
'Debug.Print errCount & " - " & Err.Number & ": " & Err.Description
Resume Retry
End Function
Is there a way to return the following Exchange Values to consolidate the function so it only looks in the exchange server once ?
Obtain .Name
.PrimarySmtpAddress
.Manager
.Manager.PrimarySmtpAddress
.Manager.Alias
I then loop through and Get Managers, Manager & Email.
I use the following SUB to be able to pull the information needed (Into a message box while building but the data will populate a table once finished).
Sub GetDetails()
Dim Name As String, Email As String, Manager As String, ManagersEmail As String, MD As String, MDEmail As String, Lookup As String
Lookup = GetManagerAlias("3511931") '("3359820")
Name = GetName(Lookup)
Email = GetEmail(Lookup)
Manager = GetManager(Lookup)
ManagersEmail = GetManagersEmail(Lookup)
MD = GetManager(GetManagerAlias(Lookup))
MDEmail = GetManagersEmail(GetManagerAlias(Lookup))
MsgBox Name & vbNewLine & Email & vbNewLine & Manager & vbNewLine & ManagersEmail & vbNewLine & MD & vbNewLine & MDEmail
End Sub