Hi,
I modified a code i found on this thread Modify Existing VBA Code
original thread use alias to fetch other contact info (email, name.. ) from outlook/GAL.
my name is to the same, but get name, title, department, manager and managers email form user email (didn't have to change much)
the code worked fine, till i added the lines to get manager's name and email, then I'm getting an error on those two lines (I am using office 2016 if that's important)
arrUsers(lngUser, 4) = .GetExchangeUserManager.Name
arrUsers(lngUser, 5) = .GetExchangeUserManager.PrimarySmtpAddress
I modified a code i found on this thread Modify Existing VBA Code
original thread use alias to fetch other contact info (email, name.. ) from outlook/GAL.
my name is to the same, but get name, title, department, manager and managers email form user email (didn't have to change much)
the code worked fine, till i added the lines to get manager's name and email, then I'm getting an error on those two lines (I am using office 2016 if that's important)
arrUsers(lngUser, 4) = .GetExchangeUserManager.Name
arrUsers(lngUser, 5) = .GetExchangeUserManager.PrimarySmtpAddress
VBA Code:
Sub GetExchangeUserDetailsFromAlias()
Dim str As String
Dim olApp As Object 'Outlook.Application
Dim olNameSpace As Object 'Outlook.Namespace
Dim olRecipient As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim arrUsers() As String
Dim lngUser As Long
Dim rngAlias As Range, rngAliasList As Range
Dim lngLastRow As Long
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNameSpace = olApp.GetNamespace("MAPI")
With Worksheets("Unique missing from 2020")
lngLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngAliasList = .Range("A2:A" & lngLastRow)
End With
ReDim arrUsers(1 To lngLastRow - 1, 1 To 5)
With Range("B1:F1")
.Value = Array("Name", "Department", "Job Title", "Manager", "Manager Email")
End With
For Each rngAlias In rngAliasList
lngUser = lngUser + 1
If Len(rngAlias.Value) > 0 Then
str = rngAlias.Value
Set olRecipient = olNameSpace.CreateRecipient(str)
olRecipient.Resolve
If olRecipient.Resolved Then
Set oEU = olRecipient.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
With oEU
arrUsers(lngUser, 1) = .Name
arrUsers(lngUser, 2) = .department
arrUsers(lngUser, 3) = .JobTitle
arrUsers(lngUser, 4) = .GetExchangeUserManager.Name
arrUsers(lngUser, 5) = .GetExchangeUserManager.PrimarySmtpAddress
End With
End If
End If
End If
Next rngAlias
rngAliasList.Offset(, 1).Resize(, 5).Value = arrUsers
Worksheets("Unique missing from 2020").Columns("A:F").EntireColumn.AutoFit
Set olApp = Nothing 'Outlook.Application
Set olNameSpace = Nothing 'Outlook.Namespace
Set olRecipient = Nothing 'Outlook.Recipient
Set oEU = Nothing 'Outlook.ExchangeUser
If lngUser Then Erase arrUsers
Set rngAlias = Nothing
Set rngAliasList = Nothing
End Sub