View member feedback to this tip.
Editor's note: Vladimir submitted this tip to SearchDomino.com after reading a tip, Remove duplicate attachments from user's e-mail database,
which was posted in January and updated in July.
Here's improved code for the tip.
1. I fixed the bug that caused only one deletion of multiple copies per run.
2. I added sender, subject and filename to the summary e-mail.
In addition, I also recommend creating a view showing only documents with attachments and using that instead of "All Documents".
Dim gsesCurrent As NotesSession
Dim grtsRemovalDescription As NotesRichTextStyle
Sub Initialize
On Error Goto ErrorHandler
Dim dbCurrent As NotesDatabase
Dim vwAllDocuments As NotesView
Dim docEmail As NotesDocument,
prevDocEmail As NotesDocument
Dim rtiBody As NotesRichTextItem
Dim nrtiEmailBody As NotesRichTextItem
Dim boolTestMode As Boolean
Dim intFileCount As Integer
Dim lngTotalBytesFreed As Long
Dim strFileNames As Variant
Dim iTotalCount As Integer, iCount As Integer
Dim strInfos As Variant, strInfo As String
Dim itemFrom As NotesItem
Select Case Messagebox("Do you wish
to permanently remove all duplicate attachments
(select No to run this utility in test mode)?",
291, "Permanently Delete?")
Case 6
boolTestMode = False
Case 7
boolTestMode = True
Case Else
Exit Sub
End Select
lngTotalBytesFreed = 0
Redim strFileNames(0)
Redim strInfos(0)
Set gsesCurrent = New NotesSession
DefineRichTextStyle
Set dbCurrent = gsesCurrent.CurrentDatabase
Set vwAllDocuments = dbCurrent.GetView ("($All)")
Set docEmail = vwAllDocuments.GetLastDocument
iTotalCount = vwAllDocuments.AllEntries.Count
iCount = 0
Do While Not (docEmail Is Nothing)
And iCount < iTotalCount
intFileCount = 0
strInfo = ""
Set prevDocEmail = vwAllDocuments.
GetPrevDocument(docEmail)
If docEmail.HasEmbedded
And docEmail.HasItem("Body") Then
Print "Scanning: " & docEmail.Subject(0)
Set rtiBody = docEmail.GetFirstItem("Body")
Set itemFrom = docEmail.GetFirstItem( "From" )
strInfo = "From: " & itemFrom.Text & "
Subject: " & docEmail.Subject(0) & " "
If ( rtiBody.Type = RICHTEXT ) Then
Forall object In rtiBody.EmbeddedObjects
If ( object.Type = EMBED_ATTACHMENT ) Then
If IsArrayMember(strFileNames,
object.Source & Cstr(object.FileSize)) Then
intFileCount = intFileCount + 1
If intFileCount = 1 Then
Call rtiBody.AddNewLine (2)
Call rtiBody.AppendStyle(grtsRemovalDescription)
Call rtiBody.AppendText
("Attachment(s) removed from this document:")
Call rtiBody.addnewline (1)
End If
Call rtiBody.AddNewLine (1)
Call rtiBody.AppendText(object.Source)
lngTotalBytesFreed =
lngTotalBytesFreed + object.FileSize
Print "Removed: " & Cstr(lngTotalBytesFreed) & " bytes"
strInfo = strInfo & " File name: " & object.Source & " "
If Not (boolTestMode) Then Call object.Remove
Else
AddToArray strFileNames,
object.Source & Cstr(object.FileSize)
End If
End If
End Forall
End If
If intFileCount > 0 Then
AddToArray strInfos, strInfo
If Not (boolTestMode) Then
Call docEmail.Save(True, True)
End If
End If
End If
Set docEmail = prevDocEmail
iCount = iCount + 1
Loop
Set docEmail = dbCurrent.CreateDocument
docEmail.Form = "Memo"
docEmail.Subject = "Results of removal
of duplicate attachments from database "
& dbCurrent.Title
Set nrtiEmailBody = docEmail.CreateRichTextItem("Body")
Call nrtiEmailBody.AppendText
("Bytes freed: " & Cstr(lngTotalBytesFreed) & Chr$(10) & Chr$(13))
For iCount = Lbound(strInfos)
To Ubound(strInfos)
Call nrtiEmailBody.AppendText
(strInfos(iCount) & Chr$(10) & Chr$(13))
Next
Call docEmail.Send
(False,gsesCurrent.EffectiveUserName)
Exit Sub
ErrorHandler:
Print {Error #} & Str(Err()) & { in line } &
Str(Erl()) & { of } & {Remove Duplicate
Attachments} & {: "} & Error$ & {"}
Resume Next
End Sub
Function AddToArray(pvarParentArray As
Variant, pvarArrayItem As Variant)
'This function appends a value of any
datatype to an array of the same datatype
On Error Goto ErrorHandler
If Isnull(pvarParentArray) Then
Redim pvarParentArray(0)
End If
Redim Preserve
pvarParentArray(Ubound(pvarParentArray) + 1)
pvarParentArray
(Ubound(pvarParentArray)) = pvarArrayItem
Exit Function
ErrorHandler:
%REM
All errors in this context assume the
array has not yet been initialized;
hence, the array is redimmed to
a bound of 0 to store the
parameter's value / object.
%END REM
Redim Preserve pvarParentArray(0)
Resume Next
End Function
Sub DefineRichTextStyle
Set grtsRemovalDescription =
gsesCurrent.CreateRichTextStyle()
grtsRemovalDescription.NotesColor = 8 'Maroon
grtsRemovalDescription.FontSize = 8
grtsRemovalDescription.Bold = True
End Sub
Function IsArrayMember (pvarParentArray
As Variant, pvarArrayItemValue
As Variant) As Variant
On Error Goto ErrorHandler
If Isnull (Arraygetindex(pvarParentArray,
pvarArrayItemValue, 5)) Then
IsArrayMember = False
Else
IsArrayMember = True
End If
Exit Function
ErrorHandler:
Redim Preserve pvarParentArray(0)
Resume Next
End Function
MEMBER FEEDBACK TO THIS TIP
Is there a way to put in a doclink to the original attachment? That would make it so much easier to find the attachment they are looking for.
—Tony R.
******************************************
I believe a mail database is not the right place to store attachments or look for them. Besides, since we remove duplicate attachments from e-mails going back and forth, all those e-mails are grouped together in the "Mail Threads" view.
—Vladimir Tankhimovich, tip author
Do you have comments on this tip? Let us know.
This tip was submitted to the SearchDomino.com tip exchange by member Vladimir Tankhimovich. 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 bimonthly tip contest and you could win a prize and a spot in our Hall of Fame.
This was first published in July 2005