Outlook resolve user name and report user's distribution groups

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.


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

Comments

Popular posts from this blog

Powerpoint countdown and current time in slides VBA

Revit area plans adding new types and references (Gross and rentable)