Getting emails of recipients, and those in the CC list through VBA in Excel-CodePudding

I have zero experience in VBA coding, but I currently have a functioning code I copied somewhere online that successfully extracts certain details from each email. I was wondering if the code can be supplemented or modified to include the email addresses of recipients and those in the CC list as well. The code is as follows -

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

CodePudding user response：

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.

CodePudding user response：

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

    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