Pulling exchange user information matching on Primary SMTP and other smtp's

0
votes

I am using excel VBA to look up on a list from OneNote pasted in form attendance notes that I am extracting email out from the Hyperlink. I am trying to match it to the exchange user information to pull back outlook information. I am getting it to work fine if the email is matching to the primary SMTP address. Some are coming through with other smtp addresses(Name prior to Marriage) from OneNote and they are not being found. In Exchange the primary SMTP is changed to the married name and the pre-marriage smtp becomes secondary. I want to be able to match to the secondary smtp if the primary doesn't match.

Here is the code that is work. Forgive the non advanced coding as I am patching this together from google searches.

Gets the email address and the Cell range to pass into the Call statement. 

Sub Get_Outlook_Data()
Dim rngEmails As Range
Dim cl As Range
Dim clrow As Long
Dim clcell As String

With Worksheets("OneNote Attendance List")
    Set rngEmails = Range("B3:" & .Range("B" & .Rows.Count).End(xlUp).Address)
End With

For Each cl In rngEmails
    cl.Select
    clrow = ActiveCell.Row
    clcell = "B" & clrow
    If Len(cl.Value) > 0 Then
        Call GetOLData(cl.Value, clcell)
    Else
        'No email in cell, ignore it
    End If
Next cl
End Sub

This sub is Gathering the Exchange user info on the SMTP 

Sub GetOLData(EmailAddress As String, StartCell As String)
    Dim OutApp 'As Outlook.Application
    Dim OutMail 'As Object
    Dim OutRecipients 'As Outlook.Recipient
    Dim Alias As String
    Dim JobT As String
    Dim Dpt As String
    Dim City As String
    Dim Ste As String
    Dim Off As String
    Dim Fnm As String
    Dim Lnm As String
    Dim Dnm As String
    Dim PosCd As String
    Dim ID As String
    Dim Cmpy As String


    On Error Resume Next
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    Set OutRecipients = OutMail.Recipients.Add(EmailAddress)
    OutRecipients.Resolve

    Alias = OutRecipients.addressEntry.GetExchangeUser.Alias
    JobT = OutRecipients.addressEntry.GetExchangeUser.JobTitle
    Dpt = OutRecipients.addressEntry.GetExchangeUser.Department
    City = OutRecipients.addressEntry.GetExchangeUser.City
    Ste = OutRecipients.addressEntry.GetExchangeUser.SateOrProvince
    Off = OutRecipients.addressEntry.GetExchangeUser.OfficeLocation
    Fnm = OutRecipients.addressEntry.GetExchangeUser.FirstName
    Lnm = OutRecipients.addressEntry.GetExchangeUser.LastName
    Dnm = OutRecipients.addressEntry.GetExchangeUser.Name
    PosCd = OutRecipients.addressEntry.GetExchangeUser.PostalCode
    ID = OutRecipients.addressEntry.GetExchangeUser.ID
    Cmpy = OutRecipients.addressEntry.GetExchangeUser.CompanyName

    ActiveCell.Offset(0, 1).Value = Alias
    ActiveCell.Offset(0, 2).Value = JobT
    ActiveCell.Offset(0, 3).Value = Dpt
    ActiveCell.Offset(0, 4).Value = City
    ActiveCell.Offset(0, 5).Value = Ste
    ActiveCell.Offset(0, 6).Value = Off
    ActiveCell.Offset(0, 7).Value = Fnm
    ActiveCell.Offset(0, 8).Value = Lnm
    ActiveCell.Offset(0, 9).Value = Dnm
    ActiveCell.Offset(0, 10).Value = PosCd
    ActiveDell.Offset(0, 11).Value = ID
    ActiveDell.Offset(0, 12).Value = Cmpy


    Set OutRecipients = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
    On Error GoTo 0
End Sub

Any Help would be great.

1
vbaexcelemailsmtp
You're going to have to clarify exactly what you want to do. Add a clear question to your question post. - HackSlash
Updated with more clarity. I want to match on Primary SMTP first then if no match I want to look at smtp. - Steve Dreibelbis
Well, it entirely depends upon what these additional addresses are. I think you are talking about searching the GAL. Check this thread: stackoverflow.com/questions/32943435/… - HackSlash
See if you can get this information from PR_EMS_AB_PROXY_ADDRESSES. stackoverflow.com/questions/51657174/… Post an answer if you do. - niton

1 Answers

0
votes

First thing I would do is remove the On Error Resume Next because it hides all of your problems. If you want to do error handling then handle the error. Never just skip over it and expect the rest of the code to run. If you want to skip that e-mail address and move on then you would have it goto the end of the sub on error.

I also noticed you aren't using "StartCell" so I added some code that would use it.

Code Cleanup:

Sub Get_Outlook_Data()
    Dim rngEmails As Range
    Dim cl As Range

    With Worksheets("OneNote Attendance List")
        Set rngEmails = .Range("B3:" & .Range("B" & .Rows.Count).End(xlUp).Address)
    End With

    For Each cl In rngEmails
        If Len(cl.Value) > 0 Then
            Call GetOLData(cl.Value, "B" & cl.Row)
        End If
    Next cl
End Sub

Sub GetOLData(EmailAddress As String, StartCell As String)
    Dim OutApp                                   'As Outlook.Application
    Dim OutMail                                  'As Object
    Dim OutRecipients                            'As Outlook.Recipient

    'On Error Resume Next ' Never do this
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    Set OutRecipients = OutMail.Recipients.Add(EmailAddress)
    OutRecipients.Resolve

    With OutRecipients.addressEntry.GetExchangeUser
        ActiveCell.Offset(0, 1).Value = .Alias
        ActiveCell.Offset(0, 2).Value = .JobTitle
        ActiveCell.Offset(0, 3).Value = .Department
        ActiveCell.Offset(0, 4).Value = .City
        ActiveCell.Offset(0, 5).Value = .SateOrProvince
        ActiveCell.Offset(0, 6).Value = .OfficeLocation
        ActiveCell.Offset(0, 7).Value = .FirstName
        ActiveCell.Offset(0, 8).Value = .LastName
        ActiveCell.Offset(0, 9).Value = .Name
        ActiveCell.Offset(0, 10).Value = .PostalCode
        ActiveCell.Offset(0, 11).Value = .ID
        ActiveCell.Offset(0, 12).Value = .CompanyName
    End With

    Set OutRecipients = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
    'On Error GoTo 0
End Sub