View FULL headers of selected message(s) in Outlook

Dim objIe ''As InternetExplorer                                                         ''ie subroutine operands

Dim wscript As New objWSCRIPT_emulator

Sub ViewInternetHeader()

    Dim olItem As Outlook.MailItem, olMsg As Outlook.MailItem

    Dim strheader As String

   InitIE "Starting View Header", objIe

    For Each olItem In Application.ActiveExplorer.Selection

        strheader = GetInetHeaders(olItem)

         MsgIE strheader, objIe

        'Set olMsg = Application.CreateItem(olMailItem)

        'With olMsg

        '    .BodyFormat = olFormatPlain

        '    .Body = strheader

        '    .Display

        'End With

       

    Next

    Set olMsg = 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'

    ' http://techniclee.wordpress.com/

    ' 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

''----------------------

Sub InitIE(ByVal strMsg, ByRef objIe)

' Subroutine to initialize the IE display box.

Dim intWidth, intHeight, intWidthW, intHeightW

Dim objShell

   Set objShell = CreateObject("WScript.Shell") ''wsh

   Set objIe = CreateObject("InternetExplorer.Application")  '''<<<<<<<<<<<<<>>>>>>>>>

   objIe.Visible = True

    

   blnFlag = True

   strIETitle = "Backlog" & String(40, "-")

  

    objIe.Toolbar = False

    objIe.StatusBar = False

    objIe.Resizable = False

    objIe.Navigate ("about:blank")

       objIe.Visible = True

    Do Until objIe.readyState = 4

      wscript.Sleep 100

    Loop

    intWidth = 800 ''objie.document.parentwindow.screen.availwidth

    intHeight = objIe.Document.parentwindow.screen.availheight

    intWidthW = objIe.Document.parentwindow.screen.availwidth * 0.6

    intHeightW = objIe.Document.parentwindow.screen.availheight * 0.6

    objIe.Document.parentwindow.resizeto intWidth, intHeight

    objIe.Document.parentwindow.MoveTo (intWidth - intWidthW) / 2, (intHeight - intHeightW) / 2

    objIe.Document.Write " " & strMsg & " "

    objIe.Document.parentwindow.Document.Body.Style.backgroundcolor = "#eeeeFF" ''"lightblue"

    objIe.Document.parentwindow.Document.Body.Scroll = "yes"

    objIe.Document.parentwindow.Document.Body.Style.Font = "10pt 'courier new'"

    objIe.Document.parentwindow.Document.Body.Style.BorderStyle = "outset"

    objIe.Document.parentwindow.Document.Body.Style.borderwidth = "4px"

   

    objIe.Document.Title = strIETitle

    wscript.Sleep 100

    objShell.AppActivate strIETitle

End Sub

Sub MsgIE(ByVal strMsg, ByRef objIe)  ''As InternetExplorer)

    ' Subroutine to display message in IE box and detect when the

    ' box is closed by the program or the user.

    Dim objIEDoc

   

    On Error Resume Next

   

    If (strMsg = "IE_Quit") Then

        blnFlag = False

        objIe.quit

    Else

        'If InStr(1, LCase(strMsg), LCase("")) = 0 Then  ''unforamtted HTML

            objIe.Document.Body.InnerText = strMsg & objIe.Document.Body.InnerText

         'Else

            'objIe.document = strMsg

         'End If

        

        If (Err.Number <> 0) Then

            Err.Clear

            blnFlag = False

            Exit Sub

        End If

        ''objShell.AppActivate strIETitle

    End If

End Sub