Option Public
Option Declare
Option Compare NoCase, NoPitch
%REM
This script provides a permanent auto-reply agent, reliable, but with a particular function :
the end user can edit and put RICH TEXT in the message, because the template is stored in a standard stationery of the mail db.
You can use it as a Return Receipt in a shared mail db.
How to use this script
- Create a Stationery in the mail database, take note of its UNID (yes I know, it looks creepy, but no other choice)
- Create an agent of type "AFTER new mail" , and paste this script within
- Set an account in the ON BEHALF owner of the agent, it will be used as the sender name
- Look below for various settings and other considerations
- The script discards replying to many kinds of useless generic emails, and by default does not reply to internal emails.
This script is based mostly on the OoO agent in the Domino Team Mailbox template, the work of Brian Green, Automated Logic Corporation
It is also based on what is recommended by HCL : https://support.hcl-software.com/csm?id=kb_article&sysparm_article=KB0033178
This script is intended to be as easy as can be to understand and to put in use. I wanted it to be working straight away as it is. And easy to understand and customize.
%END REM
Dim session As NotesSession
Dim db As NotesDatabase
Dim cutoffDateTime As NotesDateTime
Dim cutoffDateTimeV
Dim arrayFromFields
Dim StationeryDoc As NotesDocument
Dim StationeryDocSubject As NotesItem
Dim StationeryBody As NotesRichTextItem
Dim vSkipMailWithSubjectBeginningWith
Dim vSkipMailWithSubjectContaining
Dim varSkipMailFromSomeones
' *** SETTING : allow replies to emails coming from SMTP *** (so presumably from outside company)
' Expected value : True or False
Const setReplyToSMTP% = True
' *** SETTING : allow replies to emails NOT from SMTP *** (so presumably from same Domino domain)
' Expected value : True or False
Const setReplyToInternal% = True
' *** SETTING : save the reply, in the Sent view ***
' Expected value : True or False
Const setSaveReply% = False
' *** SETTING : the UNID Universal Note ID of the Stationery doc ***
' Fast trick to get the UNID :
' open the document properties box, go to 5th tab, and look for the notes:// URL value : the UNID is at the end
' Why the UNID and not the stationery name ?
' because there is no view in the standard mail template with stationeries sorted by name, or by anything else
' and I did not wish this script to need any addional design element to add in the mail db
' so I resigned to this cheap but effective solution
' Expected value : for example "BC1D004409B093F1C12589DE00283703"
Const setStationeryUNID$ = "BC1D004409B093F1C12589DE00283703"
' *** SETTING : rich text formatting of the reply with history
' The rich text style of the email in history will inherit from the text style of the last line of the BODY of the Stationery
' *** SETTING : recipient to notify of failures ***
' Much recommended to prevent issue with a missing Stationery
' Expected value : internet adress, or Notes name or Group. Leave empty if you do no wish any notification
Const setRecipientOfCriticalErrors$ = "LocalDomainAdmins"
' *** SETTING : internet address of the sender of the reply ***
' Expected value : internet adress, or Notes name or Group. Leave empty to leave default computing of the FROM.
Const setMailboxReplyTo$ = ""
' *** SETTING : Notes Name of the owner of the reply ***
' Expected value : Notes name like "CN=Bob Smith/O=Company". Leave empty to leave default computing of the FROM.
Const setMailboxPrincipal$ = ""
' *** SETTING : activates additional log with main actions of the script *** (start, end, filtered email, etc)
' Expected value : True or False
Const setRecordAction% = False
' *** SETTING : skip emails whose Subject may begins with well known strings *** (to prevent replying to replies, fwd, etc)
' Expected value : List of semi-colon LOWER CASE separated value like this : "re:;fw:;re :"
' The filter will be case insensitive
' Leave empty "" if you discard this filter
Const setSkipMailWithSubjectBeginningWith$ = "re:;tr:;re :;fwd;[ext]: re:;[ext]: tr:;[ext]: fwd:;[ext]: re :;[spam]"
' *** SETTING : same filter as previous one, but look for the string anywhere in the subject ***
Const setSkipMailWithSubjectContaining$ = "automatique;automatic "
' *** SETTING : another filter of the same kind, but look for any string in the FROM ***
' Example of value : "@domain.org;bruce.jones;info@news.net"
' Leave empty "" if you discard this filter
Const setSkipMailFromSomeones$ = ""
' *** SETTING : filter with any Formula
' Example of value : {@Contains(From;"test")} => will NOT process email whose sender contains the string "test"
' Leave empty "" if you discard this filter
Const setSkipMailWithFormula$ = {}
' *** SETTING : if set, do not reply to email if already removed from Inbox ***
' The database property "FolderReferences" must be activated to track the folder filing
Const setAutoReplyOnlyInInbox% = False
Sub Initialize
On Error GoTo ErrorHandling
Set session = New NotesSession
Set db = session.CurrentDatabase
'All unprocessed documents for this Agent.
Dim collectionUnprocessedDocs As NotesDocumentCollection
Set collectionUnprocessedDocs = db.UnprocessedDocuments
'Find unprocessed documents
Dim docEmail As NotesDocument
Set docEmail = collectionUnprocessedDocs.GetFirstDocument
If docEmail Is Nothing Then
RecordAction "Not a single new doc was found to process." , Nothing
Exit Sub
Else
RecordAction "Nb of doc to process: " & CStr(collectionUnprocessedDocs.Count) , Nothing
End If
'We don't want to send Auto Reply messages for old emails, so we discard emails older than 24 hours
'(It may happens very scarcely that an agent thinks that all the databases docs are new , and reprocess all db docs - a nightmare)
Set cutoffDateTime = New NotesDateTime( Now )
cutoffDateTime.AdjustHour( -24 )
cutoffDateTimeV = cutoffDateTime.LSLocalTime
vSkipMailWithSubjectBeginningWith = Split(setSkipMailWithSubjectBeginningWith,";")
vSkipMailWithSubjectContaining = Split(setSkipMailWithSubjectContaining,";")
varSkipMailFromSomeones = Split(setSkipMailFromSomeones,";")
'Process last emails
While Not( docEmail Is Nothing )
If( ValidateEmail(docEmail) ) Then 'Validate some more criterias
'Preparing the reply: retrieve the template
If StationeryDoc Is Nothing Then Call GetStationery
'Send a reply for this new document
Call SendAutoReply( docEmail )
End If
'Mark this document as processed.
Call session.UpdateProcessedDoc( docEmail )
'Next
Set docEmail = collectionUnprocessedDocs.GetNextDocument( docEmail )
Wend
Exit Sub
ErrorHandling:
RaiseError "" , True, False
Exit Sub
End Sub
Sub Terminate
End Sub
Function ValidateEmail ( doc As NotesDocument ) As Boolean
On Error GoTo ErrorHandling
ValidateEmail = False
'Skip documents that do not have a DeliveredDate
If Not( doc.HasItem("DeliveredDate") ) Then
RecordAction "SKIP (no DeliveryDate)" , doc
Exit Function
ElseIf Len(doc.Getfirstitem("DeliveredDate").Text) = 0 Then
RecordAction "SKIP (empty DeliveryDate)" , doc
Exit Function
End If
'Validate that we do not process old emails by mistake
If doc.DeliveredDate(0) < cutoffDateTimeV Then
RecordAction "SKIP (email is old)" , doc
Exit Function
End If
'Skip message from or not from the Internet
If( doc.HasItem("SMTPOriginator") ) Then
If setReplyToSMTP = False Then
RecordAction "SKIP (script is set to not reply to SMTP message)" , doc
Exit Function
ElseIf doc.Getitemvalue("SMTPOriginator")(0) = "" Then
RecordAction "SKIP (SMTPOriginator is empty)" , doc
Exit Function
End If
Else
If setReplyToInternal = False Then
RecordAction "SKIP (script is set to not reply to NON SMTP message)" , doc
Exit Function
End If
End If
'Skip any document that is not a Memo
If( doc.Form(0) <> "Memo" ) Then
If( doc.Form(0) <> "" ) Then
RecordAction "SKIP (not a Memo)" , doc
Exit Function
End If
End If
Dim emailSubject As String
emailSubject = LCase(doc.GetItemValue("Subject")(0))
If emailSubject <> "" Then
'Skip emails with subjects beginning with
If setSkipMailWithSubjectBeginningWith <> "" Then
ForAll v In vSkipMailWithSubjectBeginningWith
If InStr( emailSubject , v ) = 1 Then
RecordAction "SKIP (Subject begins with forbidden string : '" & v & "')" , doc
Exit Function
End If
End ForAll
End If
'Skip emails with subjects containing
If setSkipMailWithSubjectContaining <> "" Then
ForAll v In vSkipMailWithSubjectContaining
If InStr( emailSubject , v ) > 0 Then
RecordAction "SKIP (Subject contains a forbidden string : '" & v & "')" , doc
Exit Function
End If
End ForAll
End If
End If
'Skip emails with an @Formula
Dim eval As Variant
If setSkipMailWithFormula <> "" Then
eval = Evaluate( setSkipMailWithFormula, doc )
If( eval(0) = 1 ) Then
RecordAction "SKIP (filtered by formula : '" & setSkipMailWithFormula & "')" , doc
Exit Function
End If
End If
'Do not reply to email that has been removed from the Inbox
Dim IsInInbox As Boolean
If setAutoReplyOnlyInInbox = True Then
If( db.FolderReferencesEnabled ) Then
IsInInbox = False
ForAll folderReference In doc.FolderReferences
If( folderReference = "($Inbox)" ) Then
'The document is in the ($Inbox) folder
IsInInbox = True
Exit ForAll
End If
End ForAll
If IsInInbox = False Then
RecordAction "SKIP (not in Inbox)" , doc
Exit Function
End If
End If
End If
'Skip deleted documents (soft deletions)
If( doc.IsDeleted ) Then
RecordAction "SKIP (deleted)" , doc
Exit Function
End If
'Skip documents that do not have a PostedDate
'(this header is not mandatory, but maybe we consider that only junk emails do miss it ?)
If Not( doc.HasItem("PostedDate") ) Then
RecordAction "SKIP (no posted date)" , doc
Exit Function
End If
'Skip documents that are from a mailing list
If ( doc.HasItem("List_Unsubscribe") ) Then
RecordAction "SKIP (from newsgroup or advertisement - List_Unsubscribe)" , doc
Exit Function
End If
'Skip documents that already received a normal reply from a user
If( doc.HasItem("$RespondedTo") ) Then
RecordAction "SKIP (user already replied - $RespondedTo)" , doc
' Exit Function
End If
'Skip any Out Of Office replies
If( doc.HasItem("$AutoForward") ) Then
RecordAction "SKIP (out of office message - $AutoForward)" , doc
Exit Function
End If
'Skip any messages mailed by a Lotus Notes script
If( doc.SentByAgent ) Then
RecordAction "SKIP (from Lotus Notes script/agent)" , doc
Exit Function
End If
'// Do not reply to automated response systems...
If doc.HasItem("$AssistMail") Then
If doc.GetItemValue("$AssistMail")(0) = "1" Then
RecordAction "SKIP (Automated response - $AssistMail)" , doc
Exit Function
End If
End If
ValidateEmail = True
Exit Function
ErrorHandling:
RaiseError "Email subject = '" & doc.Subject(0) & "' , created on " & Format$(doc.Created,"dd/mm/yyyy hh:nn") , True, False
Exit Function
End Function
Function RecordAction ( AnyActionDescription As String , EmailDoc As NotesDocument)
If setRecordAction = False Then Exit Function
If EmailDoc Is Nothing Then
Print AnyActionDescription
Else
Print AnyActionDescription & " - Email subject : '" & EmailDoc.Subject(0) & "' , created on " & Format$(EmailDoc.Created,"dd/mm/yyyy hh:nn")
End If
End Function
Function RaiseError( AnyRelevantMessage As String, MailNotifyAdmin As Boolean , ResumeNext As Boolean )
Dim errorTxt As String
Dim dbTitle As String
dbTitle = db.Title
Dim scriptLocation As String
scriptLocation = db.Filepath & " - agent " & session.Currentagent.Name
' Build error message
If Err = 0 Then
' Handled error
errorTxt = "Handled error: " & AnyRelevantMessage
Else
' Unhandled error
errorTxt = "Unexpected error " & CStr(Err) + "." + Error$ & " at line " & CStr(Erl) & " of module " & CStr(GetThreadInfo(10)) + "() . " & AnyRelevantMessage
End If
' Send message to console
Print scriptLocation & ". " & errorTxt
' Send message to anyone in charge
If MailNotifyAdmin = True And setRecipientOfCriticalErrors <> "" Then
Dim errmemo As NotesDocument
Set errmemo = New NotesDocument(db)
errmemo.form = "memo"
errmemo.subject = "Error in db " & dbTitle & " - " & AnyRelevantMessage
errmemo.Body = |Error in database '| & dbTitle & |'
Location: | & scriptLocation & |
| & errorTxt & |
|
Call errmemo.Send(False,setRecipientOfCriticalErrors)
End If
' In some cases, we may not want to give up
If ResumeNext = True Then
Resume Next
Else
End
End If
End Function
Function SendAutoReply( doc As NotesDocument ) As Integer
On Error GoTo ErrorHandling
'Compute SendTo
Dim sendTo As String
If doc.HasItem("SMTPOriginator") Then
sendTo = doc.GetItemValue("SMTPOriginator")(0)
Else
' Email not from internet
' array of fields where we should find the original sender to whom we will respond
If IsEmpty(arrayFromFields) Then arrayFromFields = Split("$AltReplyTo;ReplyTo;$altPrincipal;AltFrom;Principal;From",";")
ForAll f In arrayFromFields
If doc.Hasitem(f) Then
If doc.GetItemValue(f)(0) <> "" Then
sendTo = doc.GetItemValue(f)(0)
Exit ForAll
End If
End If
End ForAll
If sendTo = "" Then
RecordAction "SKIP (cannot compute who to reply, value is empty)" , doc
Exit Function
End If
End If
'Skip emails with SendTo containing
If setSkipMailFromSomeones <> "" Then
ForAll v In varSkipMailFromSomeones
If InStr( LCase(sendTo) , v ) > 0 Then
RecordAction "SKIP (sendTo contains a forbidden string : '" & v & "')" , doc
Exit Function
End If
End ForAll
End If
'Create a Reply to this message, and send it.
Dim reply As NotesDocument
Set reply = New NotesDocument( db )
Call reply.MakeResponse( doc )
'Format the new message
Call reply.ReplaceItemValue( "Form", "Reply" )
Call reply.ReplaceItemValue( "$AutoForward", True )
Call reply.ReplaceItemValue( "$AssistMail", "1" )
Call reply.ReplaceItemValue( "SendTo", sendTo )
'XXXXXXXXXXXXXXXXX uncomment below if you would like to receive a BCC copy of any reply XXXXXXXXXXXXXXXXXXXXXX
'Call reply.ReplaceItemValue( "BlindCopyTo", setRecipientOfCriticalErrors )
If setMailboxPrincipal <> "" Then Call reply.ReplaceItemValue( "Principal", setMailboxPrincipal )
If setMailboxReplyTo <> "" Then
Call reply.ReplaceItemValue( "$InetPrincipal", setMailboxReplyTo )
Call reply.ReplaceItemValue( "From", setMailboxReplyTo )
End If
'Subject
reply.Subject = StationeryDocSubject.Text
'Body
'Get the content from the stationery
Dim replyBody As NotesRichTextItem
Set replyBody = StationeryBody.Copyitemtodocument(reply, "Body")
' WARNING : the below appended content will inherit the rich text style of the last line of avove Body of Stationery
'Reply with history
Call replyBody.addnewline(3)
Call replyBody.appendtext("----------------------------------------------------------------")
Call replyBody.addnewline(2)
Call replyBody.appendtext("From: " & doc.From(0))
Call replyBody.addnewline(1)
Call replyBody.appendtext("To: " & Join(doc.SendTo,", "))
Call replyBody.addnewline(1)
Call replyBody.appendtext("Date: " & CStr(doc.PostedDate(0)) )
Call replyBody.addnewline(1)
Call replyBody.appendtext("Subject: " & doc.Subject(0))
Call replyBody.addnewline(3)
Dim docBody As NotesRichTextItem
Dim docBodytexte As String
If doc.Hasitem("Body") Then
Set docBody = doc.getfirstitem("Body")
docBodytexte = docBody.Getunformattedtext()
'docBodytexte = Replace(docBodytexte,Chr$(10)& Chr$(13),"")
Call replyBody.Appendtext(docBodytexte)
End If
'Send email
If( setSaveReply = True ) Then
reply.SaveMessageOnSend = True
Else
reply.SaveMessageOnSend = False
End If
Call reply.Send( False , sendTo )
RecordAction "Automatic reply sent to '" & sendTo & "'", doc
Exit Function
ErrorHandling:
RaiseError "Replying to email subject = '" & doc.Subject(0) & "' , created on " & Format$(doc.Created,"dd/mm/yyyy hh:nn") , True, False
Exit Function
End Function
Sub GetStationery
On Error GoTo ErrorHandling
' Lookup for the stationery
Set StationeryDoc = db.GetDocumentByUNID(setStationeryUNID)
If StationeryDoc Is Nothing Then
' The Stationery cannot be found
RaiseError "Cannot find the stationery " & setStationeryUNID & " '" , True, False
End
End If
' Validate the stationery content
Set StationeryBody = StationeryDoc.Getfirstitem("Body")
If StationeryBody.ValueLength < 10 Then
' The Stationery is empty
RaiseError "The stationery " & setStationeryUNID & " '" & StationeryDoc.MailStationeryName(0) & "' is empty", True, False
End
End If
Set StationeryDocSubject = StationeryDoc.GetFirstItem("Subject")
If StationeryDocSubject.ValueLength < 10 Then
' The Stationery Subject is empty
RaiseError "The stationery " & setStationeryUNID & " '" & StationeryDoc.MailStationeryName(0) & "' has an empty Subject", True, False
End
End If
Exit Sub
ErrorHandling:
RaiseError "Stationery UNID = '" & setStationeryUNID & "'" , True, False
Exit Sub
End Sub