Export Message Header Fields to Excel

I export email meta data like From, To, Subject, Receive Date, etc. from an Outlook folder.

I found this code from https://www.vishalon.net/blog/export-outlook-from-to-subject-receive-date-and-other-meta-data-into-excel:

Option Explicit

Sub GetMailInfo()

Dim results() As String

  ' get contacts
  results = ExportEmails(True)

  ' paste onto worksheet
  Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results

    MsgBox "Completed"
End Sub

Function ExportEmails(Optional headerRow As Boolean = False) As String()

Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select

Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items

  ' if calling procedure wants header row
  If headerRow Then
    startRow = 1
  Else
    startRow = 0
  End If

  numRows = mailFolderItems.Count

  ' resize array
  ReDim tempString(1 To (numRows + startRow), 1 To 100)

  ' loop through folder items
  For i = 1 To numRows
    Set folderItem = mailFolderItems.Item(i)

    If IsMail(folderItem) Then
      Set msg = folderItem
    End If

    With msg
      tempString(i + startRow, 1) = .BCC
      tempString(i + startRow, 2) = .BillingInformation
      tempString(i + startRow, 3) = Left$(.Body, 900)  ' throws error without limit
      tempString(i + startRow, 4) = .BodyFormat
      tempString(i + startRow, 5) = .Categories
      tempString(i + startRow, 6) = .cc
      tempString(i + startRow, 7) = .Companies
      tempString(i + startRow, 8) = .CreationTime
      tempString(i + startRow, 9) = .DeferredDeliveryTime
      tempString(i + startRow, 10) = .DeleteAfterSubmit
      tempString(i + startRow, 11) = .ExpiryTime
      tempString(i + startRow, 12) = .FlagDueBy
      tempString(i + startRow, 13) = .FlagIcon
      tempString(i + startRow, 14) = .FlagRequest
      tempString(i + startRow, 15) = .FlagStatus
      tempString(i + startRow, 16) = .Importance
      tempString(i + startRow, 17) = .LastModificationTime
      tempString(i + startRow, 18) = .Mileage
      tempString(i + startRow, 19) = .OriginatorDeliveryReportRequested
      tempString(i + startRow, 20) = .Permission
      tempString(i + startRow, 21) = .ReadReceiptRequested
      tempString(i + startRow, 22) = .ReceivedByName
      tempString(i + startRow, 23) = .ReceivedOnBehalfOfName
      tempString(i + startRow, 24) = .ReceivedTime
      tempString(i + startRow, 25) = .RecipientReassignmentProhibited
      tempString(i + startRow, 26) = .ReminderSet
      tempString(i + startRow, 27) = .ReminderTime
      tempString(i + startRow, 28) = .ReplyRecipientNames
      tempString(i + startRow, 29) = .SenderEmailAddress
      tempString(i + startRow, 30) = .SenderEmailType
      tempString(i + startRow, 31) = .SenderName
      tempString(i + startRow, 32) = .Sensitivity
      tempString(i + startRow, 33) = .SentOn
      tempString(i + startRow, 34) = .Size
      tempString(i + startRow, 35) = .Subject
      tempString(i + startRow, 36) = .To
      tempString(i + startRow, 37) = .VotingOptions
      tempString(i + startRow, 38) = .VotingResponse
      tempString(i + startRow, 39) = .Attachments.Count
      tempString(i + startRow, 40) = .CIP
      tempString(i + startRow, 41) = .CTRY

    End With

    ' adding file attachment names where they exist - added by JP
    If msg.Attachments.Count > 0 Then

        For jAttach = 1 To msg.Attachments.Count
            tempString(i + startRow, 39 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
        Next jAttach

    End If

  Next i

  ' first row of array should be header values
  If headerRow Then

    tempString(1, 1) = "BCC"
    tempString(1, 2) = "BillingInformation"
    tempString(1, 3) = "Body"
    tempString(1, 4) = "BodyFormat"
    tempString(1, 5) = "Categories"
    tempString(1, 6) = "cc"
    tempString(1, 7) = "Companies"
    tempString(1, 8) = "CreationTime"
    tempString(1, 9) = "DeferredDeliveryTime"
    tempString(1, 10) = "DeleteAfterSubmit"
    tempString(1, 11) = "ExpiryTime"
    tempString(1, 12) = "FlagDueBy"
    tempString(1, 13) = "FlagIcon"
    tempString(1, 14) = "FlagRequest"
    tempString(1, 15) = "FlagStatus"
    tempString(1, 16) = "Importance"
    tempString(1, 17) = "LastModificationTime"
    tempString(1, 18) = "Mileage"
    tempString(1, 19) = "OriginatorDeliveryReportRequested"
    tempString(1, 20) = "Permission"
    tempString(1, 21) = "ReadReceiptRequested"
    tempString(1, 22) = "ReceivedByName"
    tempString(1, 23) = "ReceivedOnBehalfOfName"
    tempString(1, 24) = "ReceivedTime"
    tempString(1, 25) = "RecipientReassignmentProhibited"
    tempString(1, 26) = "ReminderSet"
    tempString(1, 27) = "ReminderTime"
    tempString(1, 28) = "ReplyRecipientNames"
    tempString(1, 29) = "SenderEmailAddress"
    tempString(1, 30) = "SenderEmailType"
    tempString(1, 31) = "SenderName"
    tempString(1, 32) = "Sensitivity"
    tempString(1, 33) = "SentOn"
    tempString(1, 34) = "size"
    tempString(1, 35) = "subject"
    tempString(1, 36) = "To"
    tempString(1, 37) = "VotingOptions"
    tempString(1, 38) = "VotingResponse"
    tempString(1, 39) = "Number of Attachments"
    tempString(1, 40) = "Attachment 1 Filename"
    tempString(1, 41) = "Attachment 2 Filename"
    tempString(1, 42) = "cip"
    tempString(1, 43) = "ctry"
  End If

  ExportEmails = tempString

  ' apply pane freeze and filtering

    Range("A2").Select
    ActiveWindow.FreezePanes = True
    Rows("1:1").Select
    'Selection.AutoFilter

End Function

Function IsMail(itm As Object) As Boolean
  IsMail = (TypeName(itm) = "MailItem")
End Function

I need to get from the message headers the Connecting IP address (CIP) and the Country (CTRY), and additionally if SPF, DKIM and DMARC pass (spf=pass, dkim=pass, and dmarc=pass).

I added the following (didn't know how to add the SPF, DKIM, and DMARC part):

    tempString(i + startRow, 40) = .CIP
    tempString(i + startRow, 41) = .CTRY

    tempString(1, 42) = "CIP"
    tempString(1, 43) = "CTRY"

I get:

Run-time error '438':
Object doesn't support this property method

How do I get CIP, CTRY, SPF, DKIM, and DMARC?

Solution

Mailitem properties:
https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem

To return "Internet headers" you can see in the Properties dialog.
https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/

Option Explicit

Private Sub ShowPropertyAssessorResult()

    ' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/
    
    Dim oItem As Object
    Dim propertyAccessor As propertyAccessor
    
    Set oItem = ActiveExplorer.Selection.item(1)
    Set propertyAccessor = oItem.propertyAccessor
    
    If oItem.Class = olMail Then
        Debug.Print "Sender Display name: " & oItem.sender
        Debug.Print "Sender address: " & oItem.SenderEmailAddress
        
        ' Internet headers
        Debug.Print "PR_TRANSPORT_MESSAGE_HEADERS", propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x007D001E")
    End If
    
End Sub

Parse the text if you see what you want there.