Get all email headers using LotusScript

View member feedback to this tip.

I recently implemented an outsourced Anti-spam and Virus Protection Service for our companies. It works very well for us, but as with any such service, some spam is bound to slip through. In order to prevent repeat spam, the service provider likes us to send the complete headers of the original e-mail so they can analyze it and deal with it.

As you may know, this is rather easy in most e-mail systems, but it's impossible to accomplish in Lotus Notes R5 in a user-friendly way -- it's very tedious and time-consuming to say the least.

To make my life easier I developed an Action Button to capture all of the headers of an R5 e-mail. I was especially concerned with the "Received" headers -- there can be many of them in a single e-mail. Accessing and working with the Received headers using LotusScript required a rather unorthodox approach.

I placed this Action Button code in the Mail (R5.0) template's ($Inbox) folder with a title of "Get Headers" and let it propagate overnight. Now, when a user calls saying spam got through, I simply have them select the message in their Inbox and click the Get Headers button. They can have it display on the screen or create a text file or both. I usually have them just display it on the screen and if I determine it really is spam, I have them create the file and send it to the service provider. Done. Finished. That's all there is to it!

  
 REM  In Action's (Declarations)
REM  Stuff used with
REM  SHBrowseForFolder
REM  Windows API call
Private Const BIF_
RETURNONLYFSDIRS = 1
Private Const BIF_
DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Type BrowseInfo
 hWndOwner As Long
 pIDLRoot As Long
 pszDisplayName As Long
 lpszTitle As Long
 ulFlags As Long
 lpfnCallback As Long
 lParam As Long
 iImage As Long
End Type

Declare Function SHBrowseForFolder 
Lib "shell32" (lpbi As BrowseInfo) As Long 
Declare Function SHGetPathFromIDList 
Lib "shell32" (Byval pidList As Long, 
Byval lpBuffer As String) As Long Declare 
Function lstrcat Lib "kernel32" 
Alias "lstrcatA" (Byval lpString1 As String, 
Byval lpString2 As String) As Long 
REM  End of Stuff REM  used with REM  
SHBrowseForFolder REM  Windows API call 
REM  End of Declarations

REM  In Action's Click event:
 REM  Created by Gary Roberts -- 
November 2004
 REM  gary@dominohelper.com
 REM  Base API Code written by
 Ulrich Krause
 REM
 REM  Feel free to use this code but 
please keep these comments in place.
 REM  View/Folder Action -- expects 
one and only one document to be 
selected.
 REM  It is designed as an Action to 
be used in the ($Inbox) folder of 
the R5.0
 REM  Mail file/template.  It is meant to 
be used on inbound SMTP e-mail.
 REM
 REM  This code is designed for the 
Windows platform but can be used on 
any
 REM  platform with a simple modification 
-- it uses an API call to
 REM  display a dialog box for getting the 
drive and folder to put the 
output file in.
 REM  If you are on a different platform 
remove the code in the 
Declarations section
 REM  and the code near the bottom 
of the Click event (this code) marked 
by:
 REM  ***************  Windows 
API Call  ***************
 REM
 REM
 On Error Goto ErrorHandler
 
 Dim session As New NotesSession
 Dim ws As New NotesUIWorkspace
 Dim db As NotesDatabase
 Dim dc As NotesDocumentCollection
 Dim doc As NotesDocument
 
 Dim HeaderContents As String
 Dim SpecificHeader As String
 Dim Subject As String
 Dim Sender As String
 Dim CRLF As String
 Dim FieldName As String
 Dim OutputFileNumber As Integer
 Dim OutputType As String
 
 Set db = session.CurrentDatabase
 Set dc = db.UnprocessedDocuments
 Set doc = dc.GetFirstDocument
 
 Subject = doc.Subject(0)
 If Subject = "" Then Subject = 
"[Subject was blank]"  ' Tag 
blank Subject
 
 Sender = doc.SMTPOriginator(0)
 If Sender = "" Then Sender = 
"[SMTPOriginator was blank]"  ' 
Tag blank sender field
 
 CRLF = Chr$(13) & Chr$(10)
 
 REM  Special case for the 
"Received" headers
 FieldName = "Received"
 SpecificHeader = ""
 While doc.HasItem( FieldName )
  Set item = doc.GetFirstItem( FieldName )
  SpecificHeader = SpecificHeader 
& Fieldname & ":  " & item.Text 
& CRLF
  Call item.Remove  ' It's okay -- 
we won't save the document so 
these will NOT be lost
 Wend
 
 HeaderContents = HeaderContents 
& SpecificHeader & CRLF
 
 Forall Header In doc.Items
  If Header.Name = "Body" Then
   HeaderContents = HeaderContents 
& CRLF & CRLF & 
Header.Name & ": " & Header.Text & CRLF
  Else
   HeaderContents = HeaderContents 
& Header.Name & ": " & 
Header.Text & CRLF
  End If
  
 End Forall  
 
 REM  see if the user wants a Display, 
a File or Both
 OutputType = ws.Prompt( PROMPT_
OKCANCELEDIT, "OutputType", "Enter 1 for 
File, 2 for Display, 3 for Both", "2" )
 If OutputType = "" Then
  Exit Sub
 End If
 
 REM  Produce output(s) specified by user 
-- Write to file if selected
 If OutputType = "1" Or OutputType = "3" 
Then
  REM  Set Defaults in case the following 
API code is stripped-
out later
  Dim OutputFilePath As String
  OutputFilePath = "c:Headers.txt"
  
  REM  ***************  Windows API 
Call  ***************
  REM  Write the Header Contents 
to a file -- Many thanks to 
Ulrich Krause
  REM  for the base code of this API call, 
which I have modified 
extensively
  Dim lpIDList As Long
  Dim sBuffer As String
  Dim szTitle As String
  Dim tBrowseInfo As BrowseInfo
  
  szTitle = "Select drive and folder for
 Output File 
(Headers.txt)"
  tBrowseInfo.hWndOwner = 0
  tBrowseInfo.lpszTitle = lstrcat( szTitle, "" )
  tBrowseInfo.ulFlags = BIF_
RETURNONLYFSDIRS + 
BIF_DONTGOBELOWDOMAIN
  
  lpIDList = SHBrowseForFolder(tBrowseInfo)
  
  If ( lpIDList ) Then
   sBuffer = Space( MAX_PATH )
   SHGetPathFromIDList lpIDList, sBuffer
   sBuffer = Left( sBuffer, Instr( sBuffer, Chr(0) ) - 1)
   OutputFilePath = sBuffer
   If Right$( OutputFilePath, 1 ) <> "" Then
    OutputFilePath = OutputFilePath & "Headers.txt"
   Else
    OutputFilePath = OutputFilePath & "Headers.txt"
   End If
   Print "Headers written to " & OutputFilePath
  End If
  REM  ***************  End of Windows 
API Call  ***************
  
  OutputFileNumber = Freefile()
  Open OutputFilePath For Output As
 #OutputFileNumber
  Print #OutputFileNumber, "From: 
 " & Sender & "       
Subject:  " & Subject  & CRLF
  Print #OutputFileNumber, "Complete 
Header Information Follows:" 
& CRLF
  Print #OutputFileNumber, HeaderContents
  Close
  Msgbox OutputFilePath,,"Headers have 
been successfully written 
to:"
 End If
 
 If OutputType = "2" Or OutputType = "3" 
Then
  REM  Display Header Contents on
 screen if selected
  Msgbox HeaderContents,, 
"SMTPOriginator:  " & Sender & "       
Subject:  " & Subject 
 End If
 Exit Sub
 
ErrorHandler:
 If Err = 101 Then Exit Sub  
' Can't open file -- User canceled out of 
location dialog box
 Msgbox "Error:  " & Err & " at line " 
& Erl,16, "Error getting header 
information"
 Exit Sub
 Resume Next

MEMBER FEEDBACK TO THIS TIP

Is there an easier way to do this in R6? I have servers running on AIX that we need to report the SMTP headers to a SPAM service. I've tried script, but have not solved how to get all the RouterServers fields -- it only reports the first one.

Here is my agent behind a button to notify a group about the spam, but I need advice to get all the SMTP headers to show the spoofing.

- - - - - - - - -  - - -  -- -
Sub Initialize
 Dim session As New NotesSession
 Dim db As NotesDatabase
 Dim collection As NotesDocumentCollection
 Dim doc As NotesDocument, 
email1 As NotesDocument
 Dim item As NotesItem
 Dim i%
 Dim send(1) As String, itemN As String
 Dim rtitem As NotesRichTextItem, 
rtBody As NotesRichTextItem
 Set db = session.CurrentDatabase
 Set collection = db.UnprocessedDocuments 
 ' all documents selected by 
user in the view
 Set doc = collection.GetFirstDocument()
 If (doc Is Nothing) Then
  Goto NoDocs
 End If
 While Not(doc Is Nothing)
  i% = 0
  Set email1  = New NotesDocument ( db )
  Set rtitem = 
New NotesRichTextItem(email1,"Body" )
  email1.Form = "Memo"
  email1.Subject = "SpamMail Report"
  send(0) = "Spam Notification"
  email1.SendTo = send
  Forall items In doc.Items
   itemN = items.Name
   If itemN = "Body" Or itemN =
 "$MIMETrack" Or itemN 
= "Form" Or itemN = "$UpdatedBy"  
Then Goto ItemContinue
   If itemN =  "$Orig" Or itemN = 
"Categories" Or itemN 
=  "$Revisions"
Or itemN =  "$MsgTrack" Then 
Goto ItemContinue
   If itemN =  "MsgTrackFlags" 
Or itemN = "RoutingState" 
Then Goto ItemContinue
   i% = i% + 1
   Call rtitem.AppendText 
( Cstr(i%) + ".  .  . " + 
items.Name + ":  " 
+ Cstr(items.Type ) + ":  " 
+ items.Text )
   Print Cstr(i%) + ".  .  . " + 
items.Name + ":  "  + Cstr
(items.Type
) + ":  " + items.Text 
   Call rtitem.AddNewLine( 1 )
ItemContinue:  
  End Forall
  Call rtitem.AddNewLine( 1 )
  Call rtitem.AppendText ("  Body text is: ")
  Call rtitem.AddNewLine( 1 )
  Set rtBody = doc.GetFirstItem( "Body" )
  Call rtitem.AppendText ( rtBody.
GetFormattedText( False, 0 ))
  Call rtitem.AddNewLine( 2 )
  Call email1.Send(False)
  Set doc = collection.GetNextDocument(doc)
 Wend
 
 Exit Sub
 
NoDocs:
 Messagebox  "You did not select any 
spam messages to report. Exiting", 
0, "NoSpamSelected"
End Sub

—Michael C.

******************************************

I believe the key to your solution is in the following code snippet from my original tip:

 REM  Special case for the "Received" 
headers  FieldName = "Received"
 SpecificHeader = ""
 While doc.HasItem( FieldName )
  Set item = doc.GetFirstItem( FieldName )
  SpecificHeader = SpecificHeader 
& Fieldname & ":  " & item.Text & CRLF
  Call item.Remove  ' It's okay -- 
we won't save the document so these will NOT 
be lost  Wend

You can set the FieldName variable to retrieve those headers you are having problems with. "Normal" methods will NOT retrieve the headers having multiple fields (NotesItems) with the same name. The code above WILL get them -- REMOVING the items as you "loop" through them is the only way. This works very well, as long as you:

A) Don't need to do a Save on the original document.

B) Don't care if you lose the headers if you DO save the original document.

It sounds a lot harder/trickier than it really is!

—Gary Roberts, tip author

******************************************

This is great tip. But how can I get content-type data from the header? There is no such data you can see when selecting View->Show->Page Source.

—Vladimir P.

******************************************

I believe the content-type headers are always contained in the Body field(s) of a Notes memo. Some, especially from Web TV, are extracted by the code I posted, even though they ARE contained in one of the Body fields. Refer to this screenshot of a file created by the code I posted in the original tip -- I've highlighted the content-type in yellow.

Try using the NotesMIMEEntity class in LotusScript to DIRECTLY access the MIME Content-related properties of a memo -- refer to Designer Help and search for MIME. It should be pretty simple.

—Gary Roberts, tip author

Do you have comments on this tip? Let us know.

This tip was submitted to the SearchDomino.com tip exchange by member Gary Roberts. Please let others know how useful it is via the rating scale below. Do you have a useful Notes/Domino tip or code to share? Submit it to our monthly tip contest and you could win a prize and a spot in our Hall of Fame.