This is a hidden action script button that we use for users who abuse the policy for e-mail retention and mailfile size limitations. The script/button is located in the action button bar within a view in the user's mailfile. The button should be hidden to all users except those in your Administrator group. (It could be destructive if put in the wrong hands.)
The script goes through all selected messages in the view and removes file attachments (which normally consume most of the size of a mailfile) from the rich-text body field of the memos. In addition, it pastes in a graphic (bmp) file at the end of the body field letting the end-user know that the attachments have been removed from the message.
The script is written assuming the graphic is the body of a memo saved as a draft in an administrative database. You could modify to use any other database you choose.
The script does not cause return receipts to fire off, but will not be able to act on encrypted messages.
The script is also helpful if you were wondering how to insert any graphic into a rich-text field, and can be modified to do so.
Sub Click(Source As Button) Dim w As New NotesUIWorkspace Dim session As New NotesSession Dim db As NotesDatabase Dim doc As NotesDocument 'db2,doc2,rtitem2 represent items in separate Admin database Dim db2 As NotesDatabase Dim doc2 As NotesDocument Dim rtitem As Variant Dim rtitem2 As NotesRichTextItem '...set value of doc... Dim collection As NotesDocumentCollection Set session=New NotesSession 'get body field of Attachment Removal Logo (inserted bmp graphic) in Stationary memo in drafts view of Admin Database Set db2=New NotesDatabase ("Server Name of Admin Db","mailadmin.nsf") 'gets the stationary using the 32digit UNID of document above Set doc2=db2.GetDocumentByUNID("7DAD168A43FAE7528525680300487878") 'gets only body field of stationary Set rtitem2=doc2.GetFirstItem ("Body") 'set db as the mailfile you run action from Set db = session.CurrentDatabase 'set collection of selected documents Set collection = db.UnprocessedDocuments Set doc = collection.GetFirstDocument Do Until doc Is Nothing 'select body of mail message and remove any attachments Set rtitem = doc.GetFirstItem( "Body" ) 'continue processing messages if encrypted message or other error encountered On Error Resume Next If (rtitem.Type=RICHTEXT) Then Forall obj In rtitem.EmbeddedObjects If (obj.Type=EMBED_ATTACHMENT) Then Call obj.Remove End If End Forall 'add two new lines at bottom of the body field rtitem.AddNewLine (2) 'copy the attachment removal logo into the mail message body field Call rtitem.AppendRTItem(rtitem2) Call doc.Save(True, True ) 'get the next document to process until finished Set doc=collection.GetNextDocument (doc) End If Loop 'prompt message when finsished Messagebox "Attachments have been removed from all selected documents.",,"Attachments Removed" 'refresh current view to show difference in size after attachments have been removed Call w.ViewRefresh End Sub