Getting Email Addresses for Recipients (Outlook)

Question

I have a code that I was able to string together that logs my sent emails into an excel sheet so i can use that data for other analysis.

In it, I have it resolving the name into an email as outlook shortens it ("Jimenez, Ramon" = email@address.com) as outlook configured this and it works when i send an email to anyone in my company as they are in my address book.

Now, when I email anyone outside it defaults to lastName, firstName so it is not converting this and logging it.

I thought the code I have in here already does this, but I guess not. I have already come this far and I am NOT a software guru at all. Does anyone have insight on how I can also include this as well?? Please see code below:

  Private WithEvents Items As Outlook.Items
  Const strFile As String = "C:\Users\a0227084\Videos\work\test.xlsx"

Private Sub Application_Startup()
  Dim OLApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Set OLApp = Outlook.Application
  Set objNS = OLApp.GetNamespace("MAPI")
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)

  On Error GoTo ErrorHandler
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then



    Set Msg = item
    ' ******************

    FullName = Split(Msg.To, ";")

    For i = 0 To UBound(FullName)

    If i = 0 Then
        STRNAME = ResolveDisplayNameToSMTP(FullName(i))
        Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
    ElseIf ResolveDisplayNameToSMTP(FullName(i)) <> "" Then
        STRNAME = ResolveDisplayNameToSMTP(FullName(i))
        Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))
    End If

    Next i


    'Call Write_to_excel(CStr(Msg.ReceivedTime), CStr(Msg.Subject), CStr(STRNAME))

  End If
ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub

Sub tes2t()



End Sub
Function getRecepientEmailAddress(eml As Variant)
    Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array

    For Each emlAddr In eml.Recipients
        If Left(emlAddr.Address, 1) = "/" Then
            ' it's an Exchange email address... resolve it to an SMTP email address
            out.Add ResolveDisplayNameToSMTP(emlAddr)
        Else
            out.Add emlAddr.Address
        End If
    Next
    getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
Function ResolveDisplayNameToSMTP(sFromName) As String
    ' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith@myco.com)
    ' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
    ' source:  https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel

    Dim OLApp As Object 'Outlook.Application
    Dim oRecip As Object 'Outlook.Recipient
    Dim oEU As Object 'Outlook.ExchangeUser
    Dim oEDL As Object 'Outlook.ExchangeDistributionList

    Set OLApp = CreateObject("Outlook.Application")
    Set oRecip = OLApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
            Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
                Set oEU = oRecip.AddressEntry.GetExchangeUser
                If Not (oEU Is Nothing) Then
                    ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
                End If
            Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
                Dim PR_SMTP_ADDRESS As String
                PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
                ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End Select
    End If
End Function
Sub Write_to_excel(str1 As String, str2 As String, str3 As String)
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWH As Worksheet

Set xlApp = CreateObject("Excel.Application")

With xlApp
.Visible = True
.EnableEvents = False
End With

Set sourceWB = Workbooks.Open(strFile, False, False)
Set sourceWH = sourceWB.Worksheets("Sheet1")



  sourceWB.Activate
  With sourceWH
        lastrow = .Cells(.rows.Count, "A").End(xlUp).Row
  End With



    sourceWH.Cells(lastrow + 1, 1) = str1
    sourceWH.Cells(lastrow + 1, 2) = str2
    sourceWH.Cells(lastrow + 1, 3) = str3

sourceWB.Save
sourceWB.Close

End Sub

Error message and corrected code

Regards, Ramon

Answer 1

First of all, there is no need to create a new Application instance in the ResolveDisplayNameToSMTP method:

Set OLApp = CreateObject("Outlook.Application")

Instead, you can use the Application property available in the Outlook VBA editor out of the box.

Second, you need to use the following code to get the SMTP address from the AddressEntry object:

  Dim PR_SMTP_ADDRESS As String
  Set PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
  ResolveDisplayNameToSMTP = oRecip.AddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)

Instead of the following line:

ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address

Read more about that in the How to get the SMTP Address of the Sender of a Mail Item using Outlook Object Model? article.