Getting email addresses of recipients, and those in the CC list through VBA in Excel

Question

I have functioning code I copied somewhere online that extracts certain details from each email.

Can the code be modified to include the email addresses of recipients and those in the CC list as well?

Sub FetchEmailData()

Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Integer

' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNs = appOutlook.getnamespace("MAPI")
'Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason

Set olFolder = olNs.session.PickFolder

' Clear
ThisWorkbook.ActiveSheet.Cells.Delete

' Build headings:
Range("A1:E1") = Array("From:", "To:", "CC:", "Date", "SenderEmailAddress")

For iRow = 1 To olFolder.items.Count
    Cells(iRow + 1, 1) = olFolder.items.Item(iRow).Sender
    Cells(iRow + 1, 2) = olFolder.items.Item(iRow).To
    Cells(iRow + 1, 3) = olFolder.items.Item(iRow).CC
    Cells(iRow + 1, 4) = olFolder.items.Item(iRow).receivedtime
        
    If olFolder.items.Item(iRow).SenderEmailType = "EX" Then
        Cells(iRow + 1, 5) = olFolder.items.Item(iRow).Sender.GetExchangeUser().PrimarySmtpAddress
    Else
        On Error Resume Next

        Cells(iRow + 1, 5) = olFolder.items.Item(iRow).SenderEmailAddress
    End If
        
Next iRow

End Sub

Answer 1

You can use the Recipients property to get all recipients of a particular mail item in Outlook. The Recipient.Type property returns or sets a long representing the type of recipient. For mail items values are shown in the OlMailRecipientType enumeration:

• olBCC - 3 - The recipient is specified in the BCC property of the Item.
• olCC - 2 - The recipient is specified in the CC property of the Item.
• olOriginator - 0 - Originator (sender) of the Item.
• olTo - 1 - The recipient is specified in the To property of the Item.

So, you may find the a Recipient object which corresponds to the CC field and use the Recipient.AddressEntry property which returns the AddressEntry object corresponding to the resolved recipient.

Set myAddressEntry = myRecipient.AddressEntry 

The AddressEntry.Address property returns or sets a string representing the email address of the AddressEntry. In case of Exchange accounts you may use the AddressEntry.GetExchangeUser method which returns an ExchangeUser object that represents the AddressEntry if the AddressEntry belongs to an Exchange AddressList object such as the Global Address List (GAL) and corresponds to an Exchange user. In that case the ExchangeUser.PrimarySmtpAddress property returns a string representing the primary Simple Mail Transfer Protocol (SMTP) address for the ExchangeUser.

You may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.

Answer 2

This demonstrates how you might apply one of the possible answers in How do you extract email addresses from the 'To' field in outlook?.

Option Explicit

Sub FetchEmailData_Call_smtpAddress()

Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object

Dim iRow As Long

' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0

Set olNs = appOutlook.getnamespace("MAPI")

Set olFolder = olNs.PickFolder

If olFolder Is Nothing Then
    Debug.Print "User cancelled."
    Exit Sub
End If

' Clear
ThisWorkbook.ActiveSheet.Cells.Delete
    
' Build headings:
Range("A1:E1") = Array("From:", "To:", "CC:", "Date", "SenderEmailAddress")

For iRow = 1 To olFolder.items.Count
        
    Set olItem = olFolder.items.Item(iRow)
        
    With olItem
        
        Cells(iRow + 1, 1) = .Sender
        Cells(iRow + 1, 2) = .To
        Cells(iRow + 1, 3) = .CC
        Cells(iRow + 1, 4) = .receivedtime
            
        If olFolder.items.Item(iRow).SenderEmailType = "EX" Then
            Cells(iRow + 1, 5) = .Sender.GetExchangeUser().PrimarySmtpAddress
        Else
            On Error Resume Next
            Cells(iRow + 1, 5) = .SenderEmailAddress
            On Error GoTo 0 ' consider mandatory
        End If
            
        ' Pass the item to smtpAddress
        smtpAddress olItem
        ' You could move the smtpAddress code into the main sub.
        ' Entering the email addresses in the next empty cells in the row, should be easier.
        
    End With
        
Next iRow
    
ThisWorkbook.ActiveSheet.Columns.AutoFit

Debug.Print "Done."

End Sub


Private Sub smtpAddress(ByVal Item As Object)

    ' https://stackoverflow.com/a/12642193/1571407

    Dim addrRecips As Object    ' Outlook.Recipients
    Dim addrRecip As Object     ' Outlook.Recipient
    Dim pa As Object            ' Outlook.propertyAccessor

    ' This URL cannot be clicked nor pasted into a browser.
    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set addrRecips = Item.Recipients

    For Each addrRecip In addrRecips
        Set pa = addrRecip.PropertyAccessor
        Debug.Print pa.GetProperty(PR_SMTP_ADDRESS)
    Next

End Sub