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

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