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, markDocumentChoice,deleteFieldChoice, 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 'strings mailServer = mailSvrName.Abbreviated copyDeleteChoice = pref.CopyDeleteChoice(0) ' "1" = copy + delete documents markDocumentChoice = pref.MarkDocumentChoice(0) ' "1" = mark documents with delete reasons deleteFieldChoice = pref.DeleteFieldChoice(0) ' "2" = delete on FailureReason field also 'integers alertThreshold = pref.AlertThreshold(0) 'threshold of deletions to trigger alert 'variants 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 mail.box 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 Else 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 Else 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 DeleteDoc: 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 SkipDeleteDoc: Set doc1 = view.GetNextDocument(doc1) 'if the document was not deleted, reset the value of doc1 to the next document in the view NextOne: Loop '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 messages. | & 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 Wend ' 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)) Wend While Instr(tempstr, convstr) <> 0 tempstr = Left(tempstr, Instr(tempstr, convstr)-1) & tostr _ & Mid(tempstr, Instr(tempstr, convstr)+Len(convstr)) Wend 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)) Wend End If ReplaceSubstring = tempstr End Function
Do you have comments on this tip? Let us know.
This tip was submitted to the SearchDomino.com 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.