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 = "http://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".