Outlook resolve user name and report user's distribution gorups
Looks up user in local tables and resolves to email address or #err
Other function looks up user and resolved user's distribution groups in Outlook.
Other function looks up user and resolved user's distribution groups in Outlook.
Attribute VB_Name = "Outlook_resolve_name"
Option Explicit
Function ResolveDisplayNameToSMTP(Name As String) As String
Dim oRecip As outlook.Recipient
Dim oEU As outlook.ExchangeUser
Dim oEDL As outlook.ExchangeDistributionList
Dim z
Set oRecip = outlook.Session.CreateRecipient(Name)
oRecip.Resolve
''try first space last name
If Not oRecip.Resolved And InStr(1, Name, ",", vbTextCompare) > 0 Then
z = Replace(Name, "(", ",", 1, -1, vbTextCompare)
z = Replace(z, ")", ",", 1, -1, vbTextCompare)
z = Split(z, ",")
Set oRecip = outlook.Session.CreateRecipient(z(1) & " " & z(0))
oRecip.Resolve
End If
''try last name only
If Not oRecip.Resolved And InStr(1, Name, ",", vbTextCompare) > 0 Then
Set oRecip = outlook.Session.CreateRecipient(z(0))
oRecip.Resolve
End If
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
ResolveDisplayNameToSMTP = oEDL.PrimarySmtpAddress
End If
End Select
Else
ResolveDisplayNameToSMTP = "#ERR"
End If
End Function
Private Sub Testresolve()
ResolveGroups ("Ron.allen@ktgy.com")
End Sub
Function ResolveGroups(Email As String) As String
Dim oRecip As outlook.Recipient
Dim oExUser As outlook.ExchangeUser
Set oRecip = outlook.Session.CreateRecipient(Email)
oRecip.Resolve
If oRecip.Resolved Then
Set oExUser = oRecip.AddressEntry.GetExchangeUser
ResolveGroups = DistLists(oExUser)
End If
End Function
''https://docs.microsoft.com/en-us/office/vba/outlook/concepts/address-book/list-the-groups-that-my-manager-belongs-to
Private Function DistLists(oExUser As outlook.ExchangeUser)
Dim oAE As outlook.AddressEntry
'Dim oExUser As Outlook.ExchangeUser
Dim oDistListEntries As outlook.AddressEntries
'Obtain the AddressEntry for CurrentUser
'Set oExUser = Outlook.Session.CurrentUser.AddressEntry.GetExchangeUser
'Obtain distribution lists that the user's manager has joined
Set oDistListEntries = oExUser.GetMemberOfList
For Each oAE In oDistListEntries
If oAE.AddressEntryUserType = _
olExchangeDistributionListAddressEntry Then
DistLists = DistLists & oAE.Name & ", "
End If
Next
If Len(DistLists) > 3 Then DistLists = Left(DistLists, Len(DistLists) - 2)
End Function
Function ResolveEmailToName(emailAddress As String) As String
Dim objOutlook As Object
Dim objNamespace As Namespace
Dim objRecipient As Recipient
Dim t As Date
Dim strName As String
Dim maxCt As Integer
' Create Outlook objects
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
' Try to resolve the email address
On Error Resume Next
Set objRecipient = objNamespace.CreateRecipient(emailAddress)
On Error GoTo 0
maxCt = 3
Do
objRecipient.Resolve
strName = objRecipient.Name
If strName Like "*@*" Then
t = Time() + 2 / 60 / 60 / 24 ''pause for a couple seconds
Do While t > Time(): Loop
Else
Exit Do
End If
maxCt = maxCt - 1
Loop While strName = "" And maxCt > 0
' Check if the email address was resolved
If Not objRecipient Is Nothing Then
ResolveEmailToName = strName
Else
ResolveEmailToName = "Name not found"
End If
' Release objects
Set objRecipient = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
End Function
Function ResolveEmailDepartment(emailAddress As String, OlExUserField As Integer) As String
Dim OutlookApp As outlook.Application
Dim OutlookNamespace As outlook.Namespace
Dim OutlookRecipient As outlook.Recipient
On Error Resume Next ' In case the email address is not found
' Create Outlook application object
Set OutlookApp = CreateObject("Outlook.Application")
' Get the Namespace object
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Resolve the recipient
Set OutlookRecipient = OutlookNamespace.CreateRecipient(emailAddress)
OutlookRecipient.Resolve
' Check if the recipient is resolved
If OutlookRecipient.Resolved Then
Select Case OlExUserField
Case 1
ResolveEmailDepartment = OutlookRecipient.AddressEntry.GetExchangeUser.Department
Case 2
ResolveEmailDepartment = OutlookRecipient.AddressEntry.GetExchangeUser.JobTitle
Case 3
ResolveEmailDepartment = OutlookRecipient.AddressEntry.GetExchangeUser.OfficeLocation
End Select
Else
ResolveEmailDepartment = "Department not found"
End If
' Release the objects
Set OutlookRecipient = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Function
%20t133819%20Microsoft_Visual_Studio.png)
Comments
Post a Comment