%REM Library ComparisonTools Created Mar 25, 2011 by Stephan H Wissel (CC) 2011 BY NC SA http://creativecommons.org/licenses/by-nc-sa/3.0/ Description: Compare a save copy of a database with one containing later changes %END REM Option Public Option Declare %REM Class CompareEnging Description: Helps comparing databases %END REM Public Class CompareEnging Private SourceServer As String Private SourceDBName As String Private TargetServer As String Private TargetDBName As String Private s As NotesSession Private reportDB As NotesDatabase Private sourceDB As NotesDatabase Private targetDB As NotesDatabase Private excludedForms List As String Private excludedFields List As String Private out As NotesStream Private eMailChangeDocument As Boolean Private documentOnlyChangedFields As Boolean %REM Sub New Description: Get going %END REM Sub New(sServer As String, sDB As String, tServer As String, tDB As String) me.SourceServer = sServer me.SourceDBName = sDB me.TargetServer = tServer me.TargetDBName = tDB Set me.s = New NotesSession Set me.reportDB = s.Currentdatabase 'Default: document only changes, don't eMail me.eMailChangeDocument = false me.reportOnlyChangedFields = true 'You might need to change this Call me.addExcludedField("$UpdatedBy") Call me.addExcludedField("$Revisions") Call me.addExcludedField("Form") End Sub %REM Property Set reportOnlyChangedFields Description: When set to true only changed fields are reported %END REM Public Property Set reportOnlyChangedFields As Boolean me.documentOnlyChangedFields = reportOnlyChangedFields End Property %REM Property Set eMailResults Description: If true sends one eMail for every changed document %END REM Public Property Set eMailResults As Boolean Me.reportOnlyChangedFields = eMailResults End Property %REM Sub addExcludedForm Description: Add a form to the list of forms to exclude %END REM Public Sub addExcludedForm(formName As String) me.excludedForms(formName) = formName End Sub %REM Sub addExcludedField Description: Adds a field to be excluded from comparison %END REM Public Sub addExcludedField(fieldName As String) me.excludedFields(fieldName)= fieldName End Sub %REM Function fixTextforHTML Description: Makes content pretty for HTML %END REM Private Function fixTextforHTML(orgText As String) As String Dim result As String result = ReplaceSubstring(orgText, "<", "<") result = ReplaceSubstring(result, ">", ">") fixTextforHTML = ReplaceSubstring(result, ";", "; ") End Function %REM Function report Description: Run the report %END REM Public Function report Dim i As long Set me.sourceDB = New NotesDatabase(me.SourceServer,me.SourceDBName) Set me.targetDB = New NotesDatabase(me.TargetServer,me.TargetDBName) If Not sourceDB.Isopen Then Call sourceDB.Open("", "") End If If Not targetDB.Isopen then Call targetDB.Open("","") End If If Not (sourceDB.Isopen And targetDB.Isopen) Then MsgBox "Can't open the databases" report = false Exit function End If Dim sDocCol As NotesDocumentCollection Dim sDoc As NotesDocument Set sDocCol = sourceDB.Alldocuments Set sDoc = sDocCol.Getfirstdocument() i = 1 Do Until sDoc Is Nothing Call me.compareSourceDoc(Sdoc, targetDB) Set sDoc = sDocCol.Getnextdocument(sDoc) i = i + 1 If i mod 100 = 0 Then Print CStr(i) + " docs processed" i = 1 End If Loop Call reportNewDocuments(targetDB) End Function %REM Sub reportNewDocuments Description: Comments for Sub %END REM Sub reportNewDocuments(targetDB As NotesDatabase) Dim tDocCol As NotesDocumentCollection Dim tDoc As NotesDocument Dim i As Integer Set tDocCol = targetDB.Alldocuments Set tDoc = tDocCol.Getfirstdocument() i = i Do Until tDoc Is Nothing Call compareTargetDoc(tDoc) Set tDoc = tDocCol.Getnextdocument(tDoc) i = i + 1 If i Mod 100 = 0 Then Print CStr(i) + " docs processed" i = 1 End If Loop End Sub %REM Sub compareTargetDoc Description: Comments for Sub %END REM Sub compareTargetDoc(tDoc As NotesDocument) Dim unid As String Dim curForm As String Dim orgDoc As NotesDocument On Error GoTo Err_compareTargetDoc unid = tDoc.Universalid curForm = tDoc.form(0) If Not IsElement(me.excludedForms(curForm)) Then Set orgDoc = me.sourceDB.Getdocumentbyunid(unid) If orgDoc Is Nothing Then Call documentSingleDoc(tDoc,"New Document report") End If End If Exit_compareTargetDoc: Exit Sub Err_compareTargetDoc: 'We end here since it didn't find the new ones Call documentSingleDoc(tDoc,"New Document report") Resume exit_compareTargetDoc End Sub %REM Sub compareSourceDoc Description: Finds if a document is new, deleted or updated %END REM Sub compareSourceDoc(sDoc As NotesDocument, tDB As NotesDatabase) On Error GoTo Err_compareSourceDoc Dim unid As String Dim curForm As String Dim tDoc As NotesDocument unid = sDoc.Universalid curForm = sDoc.form(0) If Not IsElement(me.excludedForms(curForm)) Then Set tDoc = tDb.Getdocumentbyunid(unid) Call compareTwoDocuments(sDoc,tDoc) End if Exit_compareSourceDoc: Exit Sub Err_compareSourceDoc: 'We get here it didn't find a document Call documentSingleDoc(sDoc,"Deleted Document report") Resume Exit_compareSourceDoc End Sub %REM Function documentDeletedDoc Description: Comments for Function %END REM Function documentSingleDoc(doc As NotesDocument, txtStatus As String) Dim mime As NotesMIMEEntity Dim header As NotesMIMEHeader Dim body As NotesMIMEEntity Dim oddRow As Boolean Dim curItem As NotesItem Dim newDoc As NotesDocument Set newDoc = New NotesDocument(me.reportDB) newDoc.form = "Memo" newDoc.Status = txtStatus newDoc.changes = 1 s.ConvertMIME = False ' Do not convert MIME to rich text Call newDoc.ReplaceItemValue("Form","Memo") Set mime = newDoc.CreateMIMEEntity Set header = mime.CreateHeader("Subject") Set body = mime.CreateChildEntity Call header.SetHeaderVal(txtStatus+": "+doc.form(0)) If out Is Nothing then Set out = s.CreateStream End If Call out.Truncate() oddRow = True out.WriteText(||) out.WriteText(|

|) out.WriteText(||) out.WriteText(doc.form(0)) out.WriteText(||) out.WriteText(|

|) out.WriteText(||) ForAll oneItem In doc.Items Set curItem = oneItem If oddRow Then out.WriteText(||) End ForAll out.WriteText("
FieldValue
|) oddRow = False Else out.WriteText(|
|) oddRow = True End If out.WriteText(curItem.name) out.WriteText(||) out.WriteText(fixTextforHTML(curItem.Text)) out.WriteText(|
") out.Position = 0 Call body.SetContentFromText(out,"text/html; charset=UTF-8", ENC_IDENTITY_7BIT) Call newDoc.Save(true, false) If me.eMailChangeDocument Then Call newDoc.Send(false, s.Username) End If s.ConvertMIME = True ' Restore conversion End Function %REM Sub compareTwoDocuments Description: Compares 2 documents and saves the result if needed %END REM Public Sub compareTwoDocuments(sDoc As NotesDocument, tDoc As NotesDocument) Dim mime As NotesMIMEEntity Dim header As NotesMIMEHeader Dim body As NotesMIMEEntity Dim oddRow As Boolean Dim curItem As NotesItem Dim newItem As NotesItem Dim newDoc As NotesDocument Dim changes As Integer Dim newValue As String Dim completedFields List As String Dim rowCounter As integer Set newDoc = New NotesDocument(me.reportDB) newDoc.form = "Memo" newDoc.Status = "Change report" changes = 0 s.ConvertMIME = False ' Do not convert MIME to rich text Call newDoc.ReplaceItemValue("Form","Memo") Set mime = newDoc.CreateMIMEEntity Set header = mime.CreateHeader("Subject") Set body = mime.CreateChildEntity Call header.SetHeaderVal("Change Status: "+sdoc.form(0)) If out Is Nothing Then Set out = s.CreateStream End If Call out.Truncate() oddRow = True out.WriteText(||) out.WriteText(|

|) out.WriteText(sdoc.form(0)) out.WriteText(" - ") out.WriteText(sdoc.Universalid) out.WriteText(|

|) rowcounter = 0 out.WriteText(||) ForAll oneItem In sDoc.Items Set curItem = oneItem completedFields(curItem.Name) = curItem.Name If Not IsElement(me.excludedFields(curItem.Name)) Then If tDoc.Hasitem(curItem.Name) Then Set newItem = tDoc.Getfirstitem(curItem.Name) newValue = newItem.Text Else newValue = "" End If If curItem.Text <> newValue Then changes = changes + 1 If oddRow Then out.WriteText(||) ElseIf Not me.documentOnlyChangedFields then 'This is for values that have not changed If oddRow Then out.WriteText(||) End If End If rowcounter = rowcounter + 1 'Split table into smaller units If rowcounter > 100 Then rowcounter = 0 out.WriteText(|
FieldOldNew
|) oddRow = False Else out.WriteText(|
|) oddRow = True End If out.WriteText(curItem.name) out.WriteText(||) out.WriteText(fixTextforHTML(curItem.Text)) out.WriteText(||) out.Writetext(fixTextforHTML(newValue)) out.WriteText(|
|) oddRow = False Else out.WriteText(|
|) oddRow = True End If out.WriteText(curItem.name) out.WriteText(||) out.WriteText(fixTextforHTML(curItem.Text)) out.WriteText(|
|) out.WriteText(||) End If End ForAll ForAll nextItem In tDoc.Items Set curItem = nextItem If Not IsElement(completedFields(curItem.Name)) Then If Not IsElement(me.excludedFields(curItem.Name)) then changes = changes + 1 If oddRow Then out.WriteText(||) End If End if End ForAll out.WriteText("
FieldOldNew
|) oddRow = False Else out.WriteText(|
|) oddRow = True End If out.WriteText(curItem.name) out.WriteText(||) out.WriteText("./.") out.WriteText(||) out.Writetext(curItem.Text) out.WriteText(|
") out.WriteText("

Changes found:") out.WriteText(CStr(changes)) out.WriteText("

") out.Position = 0 If changes > 0 then newDoc.changes = changes Call body.SetContentFromText(out,"text/html; charset=UTF-8", ENC_IDENTITY_7BIT) Call newDoc.Save(True, False) If me.eMailChangeDocument Then Call newDoc.Send(False, s.Username) End If End If s.ConvertMIME = True ' Restore conversion End Sub End Class 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