Get the Internet Header VBA Code Sample for Outlook

The following is the Get Internet Header code sample from Teach Yourself Outlook in 24 Hours. This code requires CDO and will not work with Outlook 2010 or Outlook 2013. CDO can be downloaded from Microsoft for use with Outlook 2007.

For an Outlook 2010/2013 version, see Get Outlook's Internet Headers using VBA

If you prefer installing a ready-to-use add-in, try PocketKnife Peek.

Copy and paste the code from this page into your ThisOutlookSession project.
To do this, click in the text box, Select All using Ctrl+A, Ctrl+C to copy.

In Outlook, press Alt+F11 to open the VBA editor and expand Microsoft Outlook Objects then double click on ThisOutlookSession to open it in the editing pane and Ctrl+V to paste the code.

The form this code uses is here.

Public Sub GetInternetHeaders()
' Initalize error handling
On Error Resume Next
' Declare constants
Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E
Dim objSession As New MAPI.Session
Dim objExplorer As Outlook.Explorer
Dim objSelection As Outlook.Selection
Dim objItem As Outlook.MailItem 'Object
Dim objMessage As MAPI.Message
Dim objFields As MAPI.Fields
Dim strheader As String
Dim InetHeader As New MSForms.DataObject

    ' MAPI property tag used
    objSession.Logon , , False, False, 0 ' Use the existing Outlook session
    
    Set objExplorer = ThisOutlookSession.ActiveExplorer
    Set objSelection = objExplorer.Selection
    
    ' Get selected Message ID
    Set objItem = objSelection.Item(1)
    Set objMessage = objSession.GetMessage(objItem.EntryID, objItem.Parent.StoreID)
    
    ' Get message fields
    Set objFields = objMessage.Fields
    
    ' Get SMTP header
    Err.Clear
    strheader = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
    If Err.Number = 0 Then
    'MsgBox strheader
    
    ' Get the message body, prefer the raw HTML if it exists
    If objItem.HTMLBody = "" Then
    msgHeader = strheader & objItem.Body
    Else
    msgHeader = strheader & objItem.HTMLBody
    End If
    
    ' Note that you must have a form in the project for this reference to work
    InetHeader.SetText (msgHeader)
    InetHeader.PutInClipboard
    frmHeader.txtHeader.Text = msgHeader
    frmHeader.Show
    Else
    MsgBox "No SMTP message header information on this message", vbInformation
    End If
    
    ' Logoff from CDO 1.21 sesison
    objSession.Logoff
    
    ' Tidy up
    Set objExplorer = Nothing
    Set objSelection = Nothing
    Set objItem = Nothing
    Set objSession = Nothing
    Set objMessage = Nothing
    Set objFields = Nothing
    Set objField = Nothing
End Sub