Manage Learn to apply best practices and optimize your operations.

LotusScript router cleanup using a profile document

In this router cleanup tip, functionality is achieved via a scheduled LotusScript agent that references a profile document containing "delete on" error messages and other options.

This is another router cleanup tip, but it's a highly configurable solution that may be of interest to some.
It's been a great time saver for our organization.
It has not been tested outside of the R6 environment.

Functionality is achieved via a scheduled LotusScript agent that references a profile document containing your "delete on" error messages and a number of other options.
A copy of the database is almost essential in putting the whole thing together, but it could be reverse-engineered based on the references in the LotusScript code.
I created a template database because we use this on two incoming SMTP servers. Using the template, modifications are easy to push out to both servers.

Two options on the profile document are whether or not to keep copies of deleted router messages (they're kept in the same db the script runs from) and whether or not to treat "Failures" the same as "Dead Failures."
You can paste in multiple "delete on" error messages and also specify "don't delete on" error messages. You can enter a threshold of deleted messages per pass and specify who to send alerts to.

The first part is the main LotusScript code for the agent. Note that it references a "ReplaceSubstring" function. Code for this function is included farther down.

Sub Initialize
'This agent uses a profile document to identify dead 
messages in the router mailbox that meet the 
administrator's criteria.
'When a message is identified, the document is 
copied to this database (the one the agent is in) 
if the profile document is set to do so.
'The message is deleted from the router mailbox, 
whether or not is copied first.
 On Error Resume Next  'if it encounters an 
error, let it go on to the next action
 Dim s As New notessession 
 Dim currentDb As NotesDatabase
 Dim routerDb As NotesDatabase  
 Dim agent As NotesAgent
 Dim agentName,agentOwner,mailServer,copyDeleteChoice,
deadFailureReason, failureReason,subMsg,alertMsg As String
 Dim alertThreshold, msgCount, delCount As Integer  'numbers  
 Dim fileName, alertRecipients, skipReasons, 
deleteReasons As Variant  'contain more than one value
 Dim view As NotesView
 Dim doc1,doc2,newMemo As NotesDocument
 Dim RTnewMemo As NotesRichTextItem   
 Set currentDb = s.CurrentDatabase
 cDbPath$ = currentDb.FilePath  
'file name of this database - used for messages 
later in document
 cDbServer$ = currentDb.Server   
'server this database resides on - used for
 messages later in document
 pass1$ = ReplaceSubstring(cDbServer$, "CN=", "")
 pass2$ = ReplaceSubstring(pass1$, "O=", "")
 cDbServer$ =  pass2$
'capture profile document
 Set pref = currentDb.GetProfileDocument("RouterCleanupProfile")
'server the mail.boxes will be on - 
must come after the profile doc has been captured
 Dim mailSvrName As New NotesName(pref.ServerName(0))
'capture agent that will run 
 Set agent = s.CurrentAgent
 agentName = agent.Name  
 agentOwner = agent.CommonOwner
'capture information from profile document 
 mailServer = mailSvrName.Abbreviated 
 copyDeleteChoice = 
pref.CopyDeleteChoice(0)  ' "1" = copy + delete documents
 markDocumentChoice = 
' "1" = mark documents with delete reasons
 deleteFieldChoice = pref.DeleteFieldChoice(0)  
 ' "2" = delete on FailureReason field also
 alertThreshold = pref.AlertThreshold(0)  
'threshold of deletions to trigger alert
 fileName = pref.FileName 
 'mail.boxes to be used with forall statement 
 alertRecipients = pref.AlertRecipients  
'who to alert if threshold is reached
 skipReasons = pref.SkipReasons 
 'white list option takes precedence if it's filled in - 
don't delete if phrases match
 deleteReasons = pref.DeleteReasons  
'phrases to match for deletion criteria
 If deleteReasons(0) = "" Then    
'don't run the agent if there isn't at least one 
phrase to delete on
  continue = False
  Exit Sub
 End If
'For every router mailbox file name listed
 in the profile document, look for string matches.
 Forall e In fileName
  Set routerDb = New NotesDatabase(mailServer, e)
  If Not routerDb.IsOpen Then
'Print unsuccessful opening of the to
 the log and quit the process.  Do not print successful opening.
   Print "Unable to open " & e & " on server " 
& mailServer & ".  Agent process aborted."
   Continue = False
   Exit Sub
  End If 
  Set view = routerDb.GetView( "Mail" ) 
 'get main view in router mailbox
  msgCount = 0  
  delCount = 0
  Set doc1 = view.GetFirstDocument 'capture first document in view
  Do While Not (doc1 Is Nothing)
   msgCount = msgCount + 1 'add this document 
to previous documents counted 
   deadFailureReason = ""     'set variable to null to 
make sure it doesn't contain previously captured data
   deadFailureReason = doc1.DeadFailureReason(0)   
'capture the DeadFailureReason field value if it exists
   If deleteFieldChoice = "2" Then  'if we're deleting
 on failure reasons also, then capture more data
    failureReason = ""     'set variable to null to
 make sure it doesn't contain previously captured data
    failureReason = doc1.FailureReason(0)   
'capture the FailureReason field value if it exists
   End If
'Don't process this document if there is
 nothing in the fields we're comparing
   If deleteFieldChoice = "2" Then
    If deadFailureReason = "" And failureReason = "" Then
     Goto SkipDeleteDoc
    End If
    If deadFailureReason = "" Then
     Goto SkipDeleteDoc
    End If
   End If
'For every string in the "Skip Delete Reasons" 
field, test for a match within the DeadFailureReason 
field & skip this document if it finds one.
   If Not skipReasons(0) = "" Then   
    Forall i In skipReasons
     If deleteFieldChoice = "2" Then       
      If  (Instr(Lcase(deadFailureReason), Lcase(i))) 
Or (Instr(Lcase(failureReason), Lcase(i))) Then
       Goto SkipDeleteDoc
      End If
      If Instr(Lcase(deadFailureReason), Lcase(i)) Then
       Goto SkipDeleteDoc
      End If
     End If
    End Forall
   End If
'For every string in the "Delete Reasons" field, test for a 
match and delete this document if one is found.
   If Not deleteReasons(0) = "" Then   
    Forall j In deleteReasons
     If Instr(Lcase(deadFailureReason), Lcase(j)) Then
      deleteReasonMatch = "DeadFailureReason: " & j
      Goto DeleteDoc
     End If
     If deleteFieldChoice = "2" Then  
      If Instr(Lcase(failureReason), Lcase(j)) Then
       deleteReasonMatch = "FailureReason: " & j
       Goto DeleteDoc
      End If
     End If
    End Forall
   End If
'If we got to this point without a match, then don't delete the document.
   Goto SkipDeleteDoc
   delCount = delCount + 1 'add this deletion count 
to everything we've already deleted
   Set doc2 = view.GetNextDocument( doc1 )
'Create a field called "DeleteReason" and resave the 
document if "Mark Documents" was chosen in the profile document.
   If markDocumentChoice = "1" Then
    doc1.DeleteReason = deleteReasonMatch
    Call doc1.Save(True,False)
   End If
'Copy the document to the database this agent is in 
if the option was chosen in the profile document.   
   If copyDeleteChoice = "1" Then   
    Call doc1.CopyToDatabase(currentDb)
   End If
'Delete the document from the router mailbox.
   Call doc1.Remove( True )   
   Set doc1 = doc2
   Goto NextOne 'if the doc was deleted, go to the loop statement
   Set doc1 = view.GetNextDocument(doc1) 
 'if the document was not deleted, reset the value of 
doc1 to the next document in the view
'Print results to the log.
  Print |'| & agentName & |' agent signed by | & agentOwner &
 | processed | & Cstr(msgCount) & | messages and deleted | 
& Cstr(delCount) & | from | & e & | on | & mailServer & |.|
'Send an alert if the deletion count is over the threshold 
set in the profile document.
  If delCount > alertThreshold Then
   Set newMemo = New NotesDocument(currentDb)
   newMemo.Form = "Memo"
   newMemo.SendTo = alertRecipients
   subMsg =  mailServer & | Router Cleanup ALERT.  
| & Cstr(delCount) & | messages deleted from | & e & |
 on | & mailServer & |.|    
   newMemo.Subject = subMsg
   newMemo.Importance = "1"    'flag the alert as 
high priority - remark this out if desired
   Set RTnewMemo = newMemo.CreateRichTextItem("Body")
   alertMsg = |The Router Cleanup process exceeded 
the alert threshold of | & alertThreshold & | deleted dead 
 | & Cstr(msgCount) & | messages were processed and
 | & Cstr(delCount) & | were deleted from | & e & | on
 | & mailServer & |.

This alert was generated by the '| & agentName & |
' agent in the | & cDbPath$ & | database on | & cDbServer$ & |. 
 If the 'Copy+Delete' option in the configuration document was
 selected, these messages were also copied to the 
same database (| & cDbPath$ & | on | & cDbServer$ & |).|
   Call RTnewMemo.AppendText(alertMsg)   
   Call newMemo.Send(False)  'don't include the form
  End If
 End Forall
End Sub

'ReplaceSubstring function
Function ReplaceSubstring(sourcestr As String, 
fromstr As String, tostr As String) As String
   ' This function replaces characters in a string. 
Take all the occurrences of "fromstr"
   ' in the source string and replace them with "tostr"
 Dim tempstr As String
 Dim convstr As String
 Dim i As Long
 Dim length As Long
 tempstr = sourcestr
 If Len(fromstr) = 0 Then
  ReplaceSubstring = sourcestr
  Exit Function
 End If
 If Instr(tostr, fromstr) <> 0 Then ' If, for example, 
"" is being replaced with ""
      ' Find a character (or set) that is not in the source string.
      ' Try the extended characters (over 128 ASCII)
  i = 128
  length = 1
  convstr = ""
  While convstr = ""
   If Instr(tempstr, String$(length, Chr$(i))) = 0 
Then convstr = String$(length, Chr$(i))
   i = i + 1
   If i = 256 Then ' If all the extended characters were in there
    length = length + 1 ' Start over, but try 2 
extended characters (or 3 or 4)
    i = 128
   End If
      ' Go through tempstr twice - 
once replacing fromstr with the computed
      ' string, then replacing the computed string with tostr
  While Instr(tempstr, fromstr) <> 0
   tempstr = Left(tempstr, Instr(tempstr, fromstr)-1) & convstr _
   & Mid(tempstr, Instr(tempstr, fromstr)+Len(fromstr))
  While Instr(tempstr, convstr) <> 0
   tempstr = Left(tempstr, Instr(tempstr, convstr)-1) & tostr _
   & Mid(tempstr, Instr(tempstr, convstr)+Len(convstr))
 Else ' It's a normal replace substring call -
 fromstr is not part of tostr
  While Instr(tempstr, fromstr) <> 0
   tempstr = Left(tempstr, Instr(tempstr, fromstr)-1) & tostr _
   & Mid(tempstr, Instr(tempstr, fromstr)+Len(fromstr))
 End If
 ReplaceSubstring = tempstr
End Function

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

This tip was submitted to the tip exchange by member Stan Erhart. 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.

Dig Deeper on LotusScript

Start the conversation

Send me notifications when other members comment.

Please create a username to comment.




  • iSeries tutorials's tutorials provide in-depth information on the iSeries. Our iSeries tutorials address areas you need to know about...

  • V6R1 upgrade planning checklist

    When upgrading to V6R1, make sure your software will be supported, your programs will function and the correct PTFs have been ...

  • Connecting multiple iSeries systems through DDM

    Working with databases over multiple iSeries systems can be simple when remotely connecting logical partitions with distributed ...