Tuesday, January 20, 2015

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






No comments:

Post a Comment