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






Comments

Popular posts from this blog

Revit area plans adding new types and references (Gross and rentable)

Organization and management of data in Revit across omniclass, Masterformat, Uniclass, and Uniformat