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