Exporting "To" addresses of incoming Outlook email - excel

Question

I've been trying to export details about my incoming emails to an Excel spreadsheet. The code works as it should except for returning display names for the recipients in the "To" and "CC" fields.
I tried several variations.
I'm using the below code that I found online:
Public WithEvents objMails As Outlook.Items
Private Sub Application_Startup()
Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim Recipient As Outlook.Recipient
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String
Dim strColumnF As String
Dim strColumnG As String
If Item.Class = olMail Then
Set objMail = Item
End If
'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strExcelFile = "C:\Users\yakir.machluf\Documents\Outlook automation test.xlsx"
'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")
'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1
'Specify the corresponding values in the different columns
strColumnB = objMail.SenderName
strColumnC = objMail.SenderEmailAddress
strColumnD = objMail.Subject
strColumnE = objMail.ReceivedTime
strColumnF = objMail.To
strColumnG = objMail.CC
'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE
objExcelWorkSheet.Range("F" & nNextEmptyRow) = strColumnF
objExcelWorkSheet.Range("G" & nNextEmptyRow) = strColumnG
'Fit the columns from A to G
objExcelWorkSheet.Columns("A:G").AutoFit
'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End Sub

Answer 1

.Recipient has an .Address property.
Recipient.Address property (Outlook) https://learn.microsoft.com/en-us/office/vba/api/outlook.recipient.address
Option Explicit
Public WithEvents objMails As Items
Private Sub Application_Startup()
Set objMails = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As MailItem
Dim i As Long
Dim recipAddresses As String
If Item.Class = olMail Then
Set objMail = Item
For i = 1 To objMail.Recipients.Count
recipAddresses = recipAddresses & objMail.Recipients(i).Address & " "
Next
Debug.Print Trim(recipAddresses)
End If
End Sub
Private Sub test_objMails_ItemAdd()
objMails_ItemAdd ActiveInspector.CurrentItem
End Sub
Code in detail:
Option Explicit
Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As MailItem
Dim recip As Recipient
Dim recipAddressesTo As String
Dim recipAddressesCC As String
Dim i As Long
Dim strExcelFile As String
' Early binding - Set reference to Excel XX.X Object Library
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Long
If Item.Class = olMail Then
Set objMail = Item
'Specify the Excel file
strExcelFile = "C:\Users\yakir.machluf\Documents\Outlook automation test.xlsx"
'Get the Excel file
' Bypass normal error handling
On Error Resume Next ' To be used for a specific purpose
Set objExcelApp = GetObject(, "Excel.Application")
' ?
Debug.Print " Error: " & Error
'If Error <> 0 Then
Debug.Print " Err..: " & Err
If Err <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
' Return to normal error handling
On Error GoTo 0 ' Consider mandatory after On Error Resume Next
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")
With objExcelWorkSheet
'Get the next empty row in the Excel worksheet
nNextEmptyRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
'Specify the corresponding values in the different columns
.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
.Range("B" & nNextEmptyRow) = objMail.senderName
.Range("C" & nNextEmptyRow) = objMail.SenderEmailAddress
.Range("D" & nNextEmptyRow) = objMail.Subject
.Range("E" & nNextEmptyRow) = objMail.ReceivedTime
For i = 1 To objMail.Recipients.Count
Set recip = objMail.Recipients(i)
If recip.Type = olTo Then
recipAddressesTo = recipAddressesTo & recip.Address & " "
ElseIf recip.Type = olCC Then
recipAddressesCC = recipAddressesCC & recip.Address & " "
End If
Next
' Trim the space character at the end
objExcelWorkSheet.Range("F" & nNextEmptyRow) = Trim(recipAddressesTo)
objExcelWorkSheet.Range("G" & nNextEmptyRow) = Trim(recipAddressesCC)
'Fit the columns from A to G
objExcelWorkSheet.Columns("A:G").AutoFit
End With
'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End If
End Sub

Answer 2

Thanks to niton, I ended up tweaking the code and using the following.
The new problem I'm facing is trying to get the exchange addresses to appear as regular email addresses.
Any hints?
Public WithEvents objMails As Outlook.Items
Private Sub Application_Startup()
Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub objMails_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim Recipient As Outlook.Recipient
Dim recipAddressesTo As String
Dim recipAddressesCC As String
Dim i As Long
Dim strExcelFile As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkBook As Excel.Workbook
Dim objExcelWorkSheet As Excel.Worksheet
Dim nNextEmptyRow As Integer
Dim strColumnB As String
Dim strColumnC As String
Dim strColumnD As String
Dim strColumnE As String
Dim strColumnF As String
Dim strColumnG As String
If Item.Class = olMail Then
Set objMail = Item
End If
'Specify the Excel file which you want to auto export the email list
'You can change it as per your case
strExcelFile = "C:\Users\yakir.machluf\Documents\Outlook automation test.xlsx"
'Get Access to the Excel file
On Error Resume Next
Set objExcelApp = GetObject(, "Excel.Application")
If Error <> 0 Then
Set objExcelApp = CreateObject("Excel.Application")
End If
Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
Set objExcelWorkSheet = objExcelWorkBook.Sheets("Sheet1")
'Get the next empty row in the Excel worksheet
nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1
'Add the vaules into the columns
objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
objExcelWorkSheet.Range("B" & nNextEmptyRow) = objMail.SenderName
objExcelWorkSheet.Range("C" & nNextEmptyRow) = objMail.SenderEmailAddress
objExcelWorkSheet.Range("D" & nNextEmptyRow) = objMail.Subject
objExcelWorkSheet.Range("E" & nNextEmptyRow) = objMail.ReceivedTime
For i = 1 To objMail.Recipients.Count
Set recip = objMail.Recipients(i)
If recip.Type = olTo Then
recipAddressesTo = recipAddressesTo & recip.Address & " "
ElseIf recip.Type = olCC Then
recipAddressesCC = recipAddressesCC & recip.Address & " "
End If
Next
' Trim the space character at the end
objExcelWorkSheet.Range("F" & nNextEmptyRow) = Trim(recipAddressesTo)
objExcelWorkSheet.Range("G" & nNextEmptyRow) = Trim(recipAddressesCC)
'Fit the columns from A to G
objExcelWorkSheet.Columns("A:G").AutoFit
'Save the changes and close the Excel file
objExcelWorkBook.Close SaveChanges:=True
End Sub