Sub Click(Source As Button)
Dim session As New NotesSession
Dim UIWorkspace As New NotesUIWorkspace
Dim db As NotesDatabase
Dim collection As NotesDocumentCollection
Dim colCount As Integer
Dim colCountStr As String
Dim uidoc As NotesUIDocument
Dim doc As NotesDocument
Dim i As Long
Dim eString As String
Dim eString2 As String
Dim view As NotesView
Dim response As Integer
Dim answer As Integer
Dim rtitem As Variant
Dim mailsProcessed As Long
Dim mailsNotProcessed As Long
Dim attachmentFileName As String
Dim typeMismatchError As Integer
Dim typeMismatchErrorCount As Integer
Dim errorString As String
On Error Goto ErrorHandler
Set db = session.CurrentDatabase
Set collection = db.UnprocessedDocuments
colCount = collection.Count
colCountStr = Cstr(colCount)
typeMismatchErrorCount% = 0
If colcount = 0 Then
Messagebox "You have not highlighted any mails!", 48,"No Mails Selected"
Exit Sub
End If
If colcount = 1 Then
eString = " email"
Else
eString = " emails"
End If
answer% = Messagebox("You are about to delete attachments from " & colCountStr & eString & " and then resave the" & eString$ & ". " &_
"The deleted attachments will NOT be saved elsewhere. Do you want to proceed?'", 36, "Delete Attachments")
If answer% > 6 Then
' Messagebox "Action aborted.", 48, "Stop"
Exit Sub
End If
mailsProcessed = 0
mailsNotProcessed = 0
typeMismatchError% = False
For i = 1 To colCount
' Print "Processing " & Cstr(i) & " of " & colCountStr
Set doc = collection.GetNthDocument( i )
Set rtitem = doc.GetFirstItem("Body")
If doc.HasEmbedded And Not rtitem Is Nothing Then ' Need to check for a body field because some system generated mails don't have one.
If ( rtitem.Type = RICHTEXT ) Then
Call rtitem.AppendText(Chr$(10) & Chr$(10) & "File Attachments Deleted on " & Format(Now(), "Long Date") & ", " & Format(Now(), "Short Time") & ":" & Chr$(10))
Forall o In rtitem.EmbeddedObjects
If typeMismatchError% = False Then
If ( o.Type = EMBED_ATTACHMENT ) Then
attachmentFileName$ = o.Source
Call o.Remove
Call rtitem.AppendText(attachmentFileName$ & Chr$(10))
Call doc.save(True, False, True)
End If
End If
typeMismatchError% = False
End Forall
mailsProcessed = mailsProcessed + 1
Else
mailsNotProcessed = mailsNotProcessed + 1
End If
Else
mailsNotProcessed = mailsNotProcessed + 1
End If
Next i
Select Case mailsProcessed
Case 0:
eString = ""
Case 1:
eString = "One email contained attachments and was processed. "
Case Else:
eString = Cstr(mailsProcessed) & " emails contained attachments and were processed. "
End Select
Select Case mailsNotProcessed
Case 0:
eString2 = ""
Case 1:
eString2 = "One email did not have any attachments and was not processed. "
Case Else:
If mailsNotProcessed = colCount Then
eString2 = "None of the selected emails had any attachments and so none of them were processed. "
Else
eString2 = Cstr(mailsNotProcessed) & " emails did not have any attachments and were not processed. "
End If
End Select
Select Case typeMismatchErrorCount%
Case 0: errorString$ = ""
Case 1: errorString$ = "Errors processing attachments on 1 email (check status bar for details)."
Case Else: errorString$ = "Errors processing attachments on " & Cstr(typeMismatchErrorCount%) & " emails (check status bar for details)"
End Select
If typeMismatchErrorCount% = 0 Then
Print "Process complete"
Else
Print "Process completed with errors. Click here for details."
End If
Messagebox eString & eString2 & errorString$, 64, "Process Complete"
Call UIWorkspace.ViewRefresh
Exit Sub
ErrorHandler:
If Err = 13 Or Err = 92 Then ' "Type Mismatch" or "For Loop not initialised"
typeMismatchError% = True
typeMismatchErrorCount% = typeMismatchErrorCount% + 1
Print "Error processing attachment on mail '" & doc.Subject(0) & "'"
Resume Next
End If
Messagebox "Error" & Str(Err) & ": " & Error$
End Sub