%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(|Field | Value |
|)
ForAll oneItem In doc.Items
Set curItem = oneItem
If oddRow Then
out.WriteText(||)
oddRow = False
Else
out.WriteText(| |
|)
oddRow = True
End If
out.WriteText(curItem.name)
out.WriteText(| | |)
out.WriteText(fixTextforHTML(curItem.Text))
out.WriteText(| |
|)
End ForAll
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(|Field | Old | New |
|)
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(||)
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(| |
|)
ElseIf Not me.documentOnlyChangedFields then 'This is for values that have not changed
If oddRow Then
out.WriteText(||)
oddRow = False
Else
out.WriteText(| |
|)
oddRow = True
End If
out.WriteText(curItem.name)
out.WriteText(| | |)
out.WriteText(fixTextforHTML(curItem.Text))
out.WriteText(| |
|)
End If
End If
rowcounter = rowcounter + 1
'Split table into smaller units
If rowcounter > 100 Then
rowcounter = 0
out.WriteText(|
|)
out.WriteText(|Field | Old | New |
|)
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(||)
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(| |
|)
End If
End if
End ForAll
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