Quickly view the internet headers of a message in Outlook

Just about anyone who runs mail servers needs to look at headers from time to time. This is especially true during the development of product such as Exchange, as we track down and fix bugs. I wrote this little macro to make that a little easier. Select a message, click the button to run the macro, and it will copy the headers from the message into the clipboard as well as open up notepad with the headers.

As always happens when I post my amateurish macros, I am expecting someone to come along and make it better : -) Every time that happens, I learn more about VBA. (Some day I really should take the time to actually learn it instead of just futzing around.)

There are two versions here: One is for Outlook 2007 only, the other for Outlook 2003 (and I assume it would also work with OL2K but haven't tried it myself). Thanks to Randy for telling me about the PropertyAccessor in OL2K7.

Instructions

  1. Add the text of the relevant macro below to Outlook
  2. Assign a toolbar button to run the macro
  3. In Outlook's VBA editor, in Tools | References, make sure there are references to "Microsoft Scripting Runtime" (should be in the list by default) and "Microsoft Forms 2.0 Object Library" (may have to browse to windows\system32\fm20.dll). If you're using Outlook 2003 you'll need CDO (Download here) and then you'll need to add "Microsoft CDO 1.21 Library" in Tools | References.
  4. Select a message, and click the toolbar button from step 2 to run the macro

Outlook 2007 

Sub KCsCopyHeadersOL2K7()
'Takes the currently selected message, copies the internet headers
'of it to the clipboard & opens notepad with the headers as well.
Dim MessageHeader As String
Dim dataObject As MSForms.dataObject
Set dataObject = New dataObject

    Const PR_TRANSPORT_MESSAGE_HEADERS = "https://schemas.microsoft.com/mapi/proptag/0x007D001E"
Dim oMail As Outlook.MailItem
If Application.ActiveExplorer.Selection.Count = 1 Then
If Application.ActiveExplorer.Selection(1).Class = olMail Then
Set oMail = Application.ActiveExplorer.Selection(1)
MessageHeader = oMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
If MessageHeader <> "" Then
dataObject.SetText MessageHeader
dataObject.PutInClipboard
Dim fso As New FileSystemObject
Dim ts As TextStream
Dim strRandFilename As String
'Note: Vista won't let you write to C:\, change this to somewhere else
strRandFilename = "C:\" & Left(Rnd * 100000, 4) & ".txt"
Set ts = fso.OpenTextFile(strRandFilename, ForWriting, True)
ts.Write (MessageHeader)
ts.Close
Shell "notepad.exe " & strRandFilename
End If
End If
End If
End Sub

Outlook 2003

Sub KCsCopyHeadersOL2K3()
'Takes the currently selected message, copies the internet headers
'of it to the clipboard & opens notepad with the headers as well.
Dim dataObject As MSForms.dataObject
Dim strInternetHeaders As String

Dim objSession As MAPI.Session
Dim objExplorer As Outlook.Explorer
Dim objSelection As Outlook.Selection

Set objSession = CreateObject("MAPI.Session")
Set objExplorer = ThisOutlookSession.ActiveExplorer
Set objSelection = objExplorer.Selection

Dim objItem As Outlook.MailItem
Dim objMessage As MAPI.Message

objSession.Logon "", "", False, False
Set objItem = objSelection.Item(1)
Set objMessage = objSession.GetMessage(objItem.EntryID, objItem.Parent.StoreID)
strInternetHeaders = objMessage.Fields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value

Set dataObject = New dataObject
dataObject.SetText strInternetHeaders
dataObject.PutInClipboard

Dim fso As New FileSystemObject
Dim ts As TextStream
Dim strRandFilename As String

strRandFilename = "c:\" & Left(Rnd * 100000, 4) & ".txt"
Set ts = fso.OpenTextFile(strRandFilename, ForWriting, True)
ts.Write (strInternetHeaders)
ts.Close

Shell "notepad.exe " & strRandFilename

End Sub

P.S. putting my name in the macros is a nod to/way of poking fun at Jensen Harris, who wrote an application that a lot of people use internally and the app is very well branded - "Office Buddy by Jensen Harris".