Rapid Viewing of Internet Headers


Last November I added a post with a VBA code fragment that retrieves the internet headers for a message. Here’s a practical example of how that code can be used to solve a problem.

Today I ran across a tweet from S1monJones commenting on how difficult it is to see the internet headers of a message in Outlook 2010. Simon makes a good point. It would be nice to be able to get to the headers without having to drill down through several selections. Fortunately there is a simpler way. By taking the code from my original post and adding a routine that calls it and passes the currently open/selected message, Simon can get to the headers with a single click.

Instructions.

  1. Start Outlook
  2. Press ALT+F11 to open Outlook’s VB editor
  3. If not already expanded, expand Project1
  4. If not already expanded, expand Modules and select Module1. If Module1 doesn’t exist, right-click Modules and select Insert > Module.
  5. Copy the code below and paste it into the right-hand pane of Outlook’s VB Editor window
  6. Click the diskette icon on the toolbar to save the changes
  7. Click the File tab.
  8. Click Options > Quick Access Toolbar.
  9. In the list under Choose commands from:, choose Macros. Find and select Project1.Module1.RapidViewingInternetHeaders
  10. Click the Add button to add the macro, and then click the Modify… button to select a button image to associate with the macro.
  11. Click OK. You should see your new button on the Quick Access Toolbar above the File tab.
  12. Sub RapidViewingInternetHeaders()
        Dim olkItm As Object, objIE As Object
        Select Case TypeName(Application.ActiveWindow)
            Case "Explorer"
                Set olkItm = Application.ActiveExplorer.Selection(1)
            Case "Inspector"
                Set olkItm = Application.ActiveInspector.CurrentItem
        End Select
        If olkItm.Class = olMail Then
            Set objIE = CreateObject("InternetExplorer.Application")
            With objIE
                .Navigate2 "about:blank"
                Do Until .readyState = 4
                    DoEvents
                Loop
                .Document.Body.innerText = GetInetHeaders(olkItm)
                .Visible = True
            End With
        End If
        Set olkItm = Nothing
        Set objIE = Nothing
    End Sub
    
    Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
        ' Purpose: Returns the internet headers of a message.'
        ' Written: 4/28/2009'
        ' Author:  BlueDevilFan'
        ' Outlook: 2007'
        Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
        Dim olkPA As Outlook.PropertyAccessor
        Set olkPA = olkMsg.PropertyAccessor
        GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
        Set olkPA = Nothing
    End Function
    

    Usage.

    To view the headers Simon will select or open a message and then click the button on the Quick Access Toolbar. The code will fetch the header from the message and display it in an Internet Explorer window.

    Advertisements

4 comments on “Rapid Viewing of Internet Headers

  1. David,
    Thanks a million. With our help I was able to complete the following code which successfully takes a mail item, strips off the attachments into a folder, then retrieves the message test and the internet header text and then appends the header+message together (via Shell commands) into a single text file that equals or approximates the original raw email file –minus attachements. I have another favorite email client (not Outlook) that then automatically retrieves the email item from the Txt_Msg folder via SMTP. I’m a beginner so I know the code is not pretty, but so far it works well.
    –Paul

    ———- Code ———

    Option Explicit

    ‘ Enumerate types of message-saving formats
    Public Enum olSaveAsTypeEnum
    olSaveAsTxt = 0
    olSaveAsRTF = 1
    olSaveAsMsg = 3
    olSaveAsHTML = 5
    olSaveAsMHTML = 10
    End Enum

    Private WithEvents Items As Outlook.Items

    ‘ Private Const MAIL_PATH As String = “C:\_D_\Local\pmmail\system\STEWA2.ACT\INBOX.FLD\”
    Private Const MAIL_PATH As String = “C:\_D_\Local\Outlook\txt_msg\”
    Private Const HEAD_PATH As String = “C:\_D_\Local\Outlook\headers\”
    Private Const DOCX_PATH As String = “C:\_D_\Local\Outlook\Attachments\”

    Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Set Ns = Application.GetNamespace(“MAPI”)
    Set Items = Ns.GetDefaultFolder(olFolderInbox).Items
    End Sub

    Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
    ‘ save message and header
    SaveMailAsFile Item, olSaveAsTxt, HEAD_PATH
    ‘ save attachments
    SaveAttachToFolder Item, “pdf”, DOCX_PATH
    SaveAttachToFolder Item, “doc”, DOCX_PATH
    SaveAttachToFolder Item, “dat”, DOCX_PATH
    SaveAttachToFolder Item, “xls”, DOCX_PATH
    SaveAttachToFolder Item, “sas”, DOCX_PATH
    SaveAttachToFolder Item, “jpg”, DOCX_PATH
    SaveAttachToFolder Item, “bmp”, DOCX_PATH
    SaveAttachToFolder Item, “txt”, DOCX_PATH
    SaveAttachToFolder Item, “ppt”, DOCX_PATH
    SaveAttachToFolder Item, “123”, DOCX_PATH
    SaveAttachToFolder Item, “rtf”, DOCX_PATH
    SaveAttachToFolder Item, “tif”, DOCX_PATH
    SaveAttachToFolder Item, “cgm”, DOCX_PATH
    SaveAttachToFolder Item, “tax”, DOCX_PATH
    SaveAttachToFolder Item, “emf”, DOCX_PATH
    ‘ save more attachements
    SaveAttachToFolder Item, “docx”, DOCX_PATH
    SaveAttachToFolder Item, “pptx”, DOCX_PATH
    SaveAttachToFolder Item, “tiff”, DOCX_PATH
    End If
    End Sub

    Private Sub SaveMailAsFile(oMail As Outlook.MailItem, eType As olSaveAsTypeEnum, sPath As String)
    Dim dtDate As Date
    Dim sNameH As String
    Dim sNameM As String
    Dim sName As String
    Dim sFile As String
    Dim sExt As String

    ‘ Is this necessary ?
    Select Case eType
    Case olSaveAsTxt: sExt = “.msg” ‘ txt
    Case olSaveAsMsg: sExt = “.msg”
    Case olSaveAsRTF: sExt = “.rtf”
    Case olSaveAsHTML: sExt = “.html”
    Case olSaveAsMHTML: sExt = “.mht”
    Case Else: Exit Sub
    End Select

    ‘ Retrieve date and time of message
    dtDate = oMail.ReceivedTime

    ‘ Specify path and filename
    sName = Format(dtDate, “yyyymmdd”, vbUseSystemDayOfWeek, vbUseSystem) _
    & Format(dtDate, “-hhnnss”, vbUseSystemDayOfWeek, vbUseSystem) _
    & “-”

    ‘ Specify path and filename for header
    sNameH = sPath _
    & “H” & sName & “.txt”

    ‘ Specify path and filename for message
    sNameM = sPath _
    & “M” & sName & “.txt” ‘ sExt

    ‘ Specify path and filename for header+message
    ‘ sName = sPath _
    & “E” & sName & “.txt”

    ‘ Save header as a text file
    ‘ Written by David Lee
    ‘ August 2011
    Dim objFSO As Object
    Dim objFile As Object
    Set objFSO = CreateObject(“Scripting.FileSystemObject”)
    Set objFile = objFSO.CreateTextFile(sNameH, True)
    objFile.Write GetInetHeaders(oMail)
    objFile.Close
    Set objFSO = Nothing
    Set objFile = Nothing

    ‘ Save message as a text file
    oMail.SaveAs sNameM, eType

    ‘ Append the two files together
    Dim RetVal
    Dim D As String
    D = sName
    RetVal = Shell(“cmd /K CD C:\_D_\Local\Outlook\Headers\ & copy H” & D & “.txt+Space.txt+M” & D & “.txt E” & D & “.msg & Dir & Dir & Exit”, vbHide) ‘ vbNormalFocus)
    RetVal = Shell(“cmd /K Copy C:\_D_\Local\Outlook\Headers\E” & D & “.msg C:\_D_\Local\Outlook\Txt_Msg\E” & D & “.msg & CD C:\ & Exit”, vbHide) ‘ vbNormalFocus)
    RetVal = Shell(“cmd /K Del C:\_D_\Local\Outlook\Headers\E” & D & “.msg & Dir & Dir & Exit”, vbHide) ‘ vbNormalFocus)
    RetVal = Shell(“cmd /K Del C:\_D_\Local\Outlook\Headers\H” & D & “.txt & Dir & Dir & Exit”, vbHide) ‘ vbNormalFocus)
    RetVal = Shell(“cmd /K Del C:\_D_\Local\Outlook\Headers\M” & D & “.txt & Dir & Dir & Exit”, vbHide) ‘ vbNormalFocus)

    End Sub

    Private Sub SaveAttachToFolder(oMail As Outlook.MailItem, ExtString As String, sPath As String)
    Dim Atmt As Attachment
    Dim FileName As String
    Dim J As Integer
    J = 0 ‘ Unnecessary
    For Each Atmt In oMail.Attachments
    If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
    ‘ FileName = sPath & oMail.SenderName & ” ” & Atmt.FileName
    FileName = sPath & Atmt.FileName
    Atmt.SaveAsFile FileName
    J = J + 1
    End If
    Next Atmt
    End Sub

    Function GetInetHeaders(olkMsg As Outlook.MailItem) As String
    ‘ Purpose: Returns the internet headers of a message.’
    ‘ Written: 4/28/2009’
    ‘ Author: BlueDevilFan’
    ‘ Outlook: 2007’
    Const PR_TRANSPORT_MESSAGE_HEADERS = “http://schemas.microsoft.com/mapi/proptag/0x007D001E”
    Dim olkPA As Outlook.PropertyAccessor
    Set olkPA = olkMsg.PropertyAccessor
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Set olkPA = Nothing
    End Function

    • Hi, Paul.

      I’m assuming you mean that you want to save to a file in lieu of displaying the header in an Internet Explorer window. If that’s correct, then replace the RapidViewingInternetHeaders with the version below.

      Sub RapidViewingInternetHeaders()
          Dim olkItm As Object, objFSO As Object, objFile As Object
          Select Case TypeName(Application.ActiveWindow)
              Case "Explorer"
                  Set olkItm = Application.ActiveExplorer.Selection(1)
              Case "Inspector"
                  Set olkItm = Application.ActiveInspector.CurrentItem
          End Select
          If olkItm.Class = olMail Then
              Set objFSO = CreateObject("Scripting.FileSystemObject")
              'On the next line change the file name and path as desired'
              Set objFile = objFSO.CreateTextFile("C:\MessageHeader.txt", True)
              objFile.Write GetInetHeaders(olkItm)
              objFile.Close
          End If
          Set olkItm = Nothing
          Set objFSO = Nothing
          Set objFile = Nothing
      End Sub
      

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s