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 firstname.lastname@example.org 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
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
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.
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.