Exporting "To" addresses of incoming Outlook email

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

Possible duplicate of [How do you extract email addresses from the 'To' field in outlook?](https://stackoverflow.com/questions/12641704/how-do-you-extract-email-addresses-from-the-to-field-in-outlook) — niton, Aug 30 '20 at 18:46

niton · Accepted Answer · 2020-08-23T22:09:32.310

.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

Many thanks for this. Excuse me as I'm fairly new to this, and while I understand your clarification, I'm not sure as to where should I incorporate this addition in my code. — Yakir Machluf, Aug 23 '20 at 09:32
Thanks! it actually didn't work as posted and I tweaked it a bit and it now works perfectly except for exchange addresses. — Yakir Machluf, Aug 27 '20 at 12:45
You may accept **if you wish**. The question will then not be bumped automatically every few months. — niton, Aug 27 '20 at 17:56

score 0 · Answer 2 · answered Sep 03 '20 at 10:39

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

This [post](https://stackoverflow.com/questions/12641704/how-do-you-extract-email-addresses-from-the-to-field-in-outlook) describes SMTP addresses. I am no longer on Exchange so cannot confirm working code. There should be many other posts about the same topic if this id not sufficient. — niton, Sep 03 '20 at 15:53
Misuse of `On Error Resume Next` is one of the biggest obstacles to success in VBA. [Error Handling In VBA](http://www.cpearson.com/excel/errorhandling.htm). You compound this with `If Error` instead of `If Err`. The purpose was to first check whether Excel is open. In your code a new instance is always created. Since you do not return to normal error handling `On Error GoTo 0` any subsequent errors are hidden. If code runs but does nothing you have no idea what line to fix if there is an error. — niton, Sep 03 '20 at 15:54

Exporting "To" addresses of incoming Outlook email

2 Answers2