Remove double NAB Documents

Sometimes I have to use the Domino Mailtemplate function "Synchronize Address Book",
which "tries" to synchronize the NAB entries from the current private Addressbook and the mailfile.
But if you have several machines with local NAB's, this could get a mess, because the code in the synchronize
agent doesn't work like a replication, so after synchronizing several local NABs with local mailboxes, you get
several double documents.

This code removes them either automatically or, if it could not decide that, with user interaction.
The alogorythm worked in the following way

LotusScript Code

Sub Initialize
Dim session As New NotesSession
Dim db As NotesDatabase
Dim col As NotesDocumentCollection
Dim doc As NotesDocument
Dim addressDocs List As AddressEntry
Dim entry As AddressEntry
Dim i As Long, ii As Long, iii As Long, delDocCount As Long

Set db = session.CurrentDatabase ' Get all documents
Set col = db.UnprocessedDocuments

Set doc = col.GetFirstDocument ' Iterate over all and store them
Do While Not doc Is Nothing
Set addressDocs(i) = New AddressEntry(doc)
Set doc = col.GetNextDocument(doc)
i = i + 1
Call showProgress(i, col.Count, 50, "Check and remove")
Loop

For ii = 0 To i - 1 ' Check each of them against eaach other
For iii = ii + 1 To i - 1
Set entry = addressDocs(ii).compare(addressDocs(iii))
If Not entry Is Nothing Then
delDocCount = delDocCount + 1
Call entry.Remove()
End If
Next
Next

If delDocCount > 0 Then
Print "Removed " + Cstr(delDocCount) + " documents from Private NAB"
End If
End Sub

' ______________________________________________________________________
' Sub showProgress()
'
' Shows the progress of a task in the status bar
'
' Parameter
' anz As Long (In) : Count of the done steps
' gesamt As Long (In) : Total count of all steps of a task
' anzChar% (In) : Length of the Text ProgressBars
' _____________________________________________________________________
Function showProgress(anz As Long, gesamt As Long, anzChar%, Prefix$) As String
Dim fract As Double, enable%, out$
Static fractInt%

If gesamt = 0 Then Exit Function
fract = anz/gesamt
enable = 100 * fract
If enable >= FractInt Or anz = 1 Then
fractInt = enable + 1
Print Prefix;" (" & Format(enable) & "%) : >";String(anzChar * Abs(1 - fract), ".");"<"
End If
End Function

'_______________________________________________________
' class for NAB entry. Holds appropriate keyvalues for comparation
' and methods for the decission, which double NAB Entry could be
' removed
'_______________________________________________________
Class AddressEntry
Private m_uniqueID As String
Private m_EmailAddress As String
Private m_Fullname As String
Private m_ModifiedDate As NotesDatetime
Private m_Doc As NotesDocument

Property Get UniqueID As String
uniqueID = m_uniqueID
End Property
Property Get eMailAddress As String
eMailAddress = m_eMailAddress
End Property
Property Get Fullname As String
Fullname = m_Fullname
End Property
Property Get ModifiedDate As NotesDatetime
Set ModifiedDate = m_ModifiedDate
End Property
Property Get Doc As NotesDocument
Set doc = m_doc
End Property

'_______________________________________________________
' Constructor
' Sets all approprate values and a unique ID for identification
'_______________________________________________________
Sub new(Doc As NotesDocument)
Dim ret
m_EmailAddress = doc.GetItemValue("MailAddress")(0)
m_Fullname = doc.GetItemValue("Firstname")(0) + " " + doc.GetItemValue("Middlename")(0) + " " + doc.GetItemValue("Lastname")(0)
Set m_ModifiedDate = New NotesDateTime(doc.LastModified)
Set m_Doc = doc
ret = Evaluate("@Unique")
m_uniqueID = ret(0)
End Sub

'_______________________________________________________
' Function compare(extAddressEntry As AddressEntry) As AddressEntry
' This function returns the entry, whic is older then an identical one.
' If the email adress is not identical, we look for the fullname
' and if this is identical, we let the user decide
' Parameter
' extAddressEntry As AddressEntry : Entry to compare with
' Return
' Entry which is identical and older or nothing
'_______________________________________________________
Function compare(extAddressEntry As AddressEntry) As AddressEntry
Dim ws As NotesUIWorkspace
Dim array(1) As String, ret

If Me.doc Is Nothing Or extAddressEntry Is Nothing Then Exit Function ' Some of the entries has a deleted document, so compare is invalid
If Strcomp(Me.uniqueID, extAddressEntry.uniqueID) = 0 Then Exit Function ' Identical entries, compare is invalid

If Strcomp(Me.eMailAddress, extAddressEntry.eMailAddress, 5) = 0 And _
Len(Me.eMailAddress+extAddressEntry.eMailAddress) > 0 Then ' Is email adress equal and not null
If m_ModifiedDate.TimeDifference(extAddressEntry.ModifiedDate) < 0 Then ' Then remove the older document
Set compare = Me ' This one is older
Else
Set compare = extAddressEntry
End If
Else ' eMail address not identical or null
If Len(Me.eMailAddress+extAddressEntry.eMailAddress) = 0 Then ' eMailaddress is null
If m_ModifiedDate.TimeDifference(extAddressEntry.ModifiedDate) > 0 Then ' Then remove the older document
Set compare = Me
Else
Set compare = extAddressEntry
End If
Else
If Strcomp(Me.fullname, extAddressEntry.Fullname) = 0 Then ' Fullname identical?
Set ws = New NotesUIWorkspace ' Let the user decide
array(0) = Me.fullname + " [" + Me.emailaddress + "]"
array(1) = extAddressEntry.fullname + " [" + extAddressEntry.emailaddress + "]"
ret = ws.Prompt(4, "Remove documents","Which one of the following NAB entries do you want to keep (Cancel kepp both)?", array(0), array)
If Not Isempty(ret) Then
If Len(ret) > 0 Then
If Strcomp(ret, array(0)) = 0 Then
Set compare = extAddressEntry
Else
Set compare = Me
End If
End If
End If
End If
End If
End If
End Function

'_______________________________________________________
' Sub Remove
' This function removes the stored document and set the internal
' property to nothing
'_______________________________________________________
Sub Remove()
Call m_doc.Remove(True)
Set m_doc = Nothing
End Sub

End Class


Submitted by	Category	Review Cycle	.	Public
Joachim Mutter/sysarc on 01/12/2009 at 11:28 AM	Notes\Script