Microsoft Outlook: Automatically add an "(Attachment deleted: filename.ext)" note when removing e-mail attachments

If you are using Microsoft Outlook, chances are that you are in a corporation and your mailbox has a limited size. Therefore, you need to delete e-mails often, or at least the biggest file attachments.

In Mozilla Thunderbird, when you delete an e-mail attachment, the e-mail still remembers the attachment's filename, so that you know that an attachment was there in the past. However, in Microsoft Outlook, if you delete an attachment, it's gone without trace. Later on, you don't know if an e-mail ever had an attachment, or who sent you a particular file.

This script emulates Thunderbird's behaviour in Outlook. Usage scenarios are:


 * 1) You open an e-mail, press the button associated to this script, and then attachments are gone, but text lines like the following are automatically prepended to the e-mail:        [Attachment deleted: myfile1.zip]        [Attachment deleted: myfile2.zip] The e-mail is marked as modified but not automatically saved. You can then discard changes and get your attachments back if you wish. This is the scenario I had in mind when I wrote this script.
 * 2) You can also mark several e-mails without opening them and do the same as for case (1). If there is more than one e-mail, you'll get a confirmation dialog box. There are 2 different ways to approach this task:
 * 3) You don't open the e-mails. The script would need to save changes immediately. Otherwise, all changes will be lost without confirmation when you close Outlook. I chose not do to this, because it's risky, the user can lose important data.
 * 4) Open all e-mails and modify them. This is similar to scenario (1), but may leave behind many open e-mails. Every time the user tries to close one, he'll be prompt in ordre to save or discard the changes. This is the option I chose to implement.

It would have been better to decide between (1) and (2.2) based on whether the user has selected e-mails on a list, or whether the user has opened a single e-mail. However, I don't know how to distinguish those scenarios yet in VBA code.

The following script has been tested with Outlook 2010.

In order to install this script in your Outloook, you need to enable the developer tools ribbon, copy the source code below to the default project, and then create a ribbon icon for it on all the ribbons you would like to access this script from.

Public Sub DeleteAttachmentsButLeaveTheirFilenamesBehind

On Error GoTo ErrorHandler:

Dim objOL As Outlook.Application Set objOL = CreateObject("Outlook.Application") Dim objSelection As Outlook.Selection Set objSelection = objOL.ActiveExplorer.Selection ' In the first pass, we just count the number of attachments to delete, ' in order to ask for confirmation if necessary.

Dim emailCount As Integer Dim attachmentCount As Integer Dim objMsg1 As MailItem

For Each objMsg1 In objSelection If objMsg1.Class = olMail Then emailCount = emailCount + 1 Dim objAttachments1 As Outlook.Attachments Set objAttachments1 = objMsg1.Attachments Dim msgAttachmentCount1 As Long msgAttachmentCount1 = objAttachments1.Count attachmentCount = attachmentCount + objAttachments1.Count End If   Next Dim msgboxRes As VbMsgBoxResult If emailCount = 0 Then msgboxRes = MsgBox("No e-mails selected.", vbOKOnly + vbCritical) Exit Sub End If   If attachmentCount = 0 Then msgboxRes = MsgBox("No attachments found in " & emailCount & " e-mail(s).", vbOKOnly + vbCritical) Exit Sub End If   If emailCount > 1 Then msgboxRes = MsgBox("Would you like to remove " & attachmentCount & " attachment(s) from " & emailCount & " e-mail(s)?", vbYesNo + vbQuestion + vbDefaultButton2) If msgboxRes = vbNo Then Exit Sub End If   End If

' In the second pass, we remove the attachments. Note that the e-mails could have changed in the meantime. ' However, it's rare to hit that window of opportunity. Dim deletedMsg As String Dim objMsg2 As MailItem

For Each objMsg2 In objSelection If objMsg2.Class = olMail Then ' Open all e-mails we are going to change. Otherwise, if the user closes Outlook, any changes will be discarded. ' See the big comment above for more information. objMsg2.Display Dim objAttachments2 As Outlook.Attachments Set objAttachments2 = objMsg2.Attachments Dim msgAttachmentCount2 As Long msgAttachmentCount2 = objAttachments2.Count If msgAttachmentCount2 > 0 Then deletedMsg = ""

Dim i As Long For i = msgAttachmentCount2 To 1 Step -1 deletedMsg = "[Attachment deleted: " & objAttachments2.Item(i).FileName & "]" & vbCrLf & deletedMsg objAttachments2.Item(i).Delete Next i               deletedMsg = deletedMsg & vbCrLf Dim objInsp As Outlook.Inspector Set objInsp = objMsg2.GetInspector Dim objDoc As Object ' I haven't found out yet how to reference the Word classes from an Outlook 2010 VBA project, ' so I had to use a generic 'Object' type instead. The WdProtectionType constants below ' are not defined either, so I had to use their numeric values. Set objDoc = objInsp.WordEditor ' This was an attempt to execute the "EditMessage" command on thee-mail, ' but the call to 'Unprotect' below fails on my Outlook 2010: ' If you open an e-mail from the 'Drafts' folder, you can change it straight away. Otherwise, you normally ' get a write-protected view, where you can delete attachments (!) but not modify the text. ' In order to lift the protection, I tried a number of ways: ' - ActiveWindow.View.ReadingLayout = False ' - objDoc.UnProtect ' - objDoc.Protect WdProtectionType.wdNoProtection ' - objOL.ActiveInspector.CommandBars.ExecuteMso ("EditMessage") ' None of the above worked, but I did find a method to remove the protection, see below: If objDoc.ProtectionType = 3 Then ' Value 3 means WdProtectionType.wdAllowOnlyReading. objInsp.CommandBars.ExecuteMso ("EditMessage") End If               If True Then ' This method seems to work for all possible e-mail formats. objDoc.Characters(1).InsertBefore deletedMsg Else ' Old method, now unused, only kept for future reference. If objMsg2.BodyFormat = olFormatHTML Then ' Here we should do HTML escaping. deletedMsg = Replace(deletedMsg, vbCrLf, " ") objMsg2.HTMLBody = " " & deletedMsg & " " & objMsg2.HTMLBody ElseIf objMsg2.BodyFormat = olFormatRichText Then ' I did not manage to edit the RTF format directly yet, because objMsg2.RTFBody ' is not a string, but an array of bytes. Err.Raise vbObjectError,, "Modifying an e-mail in RTF format not supported yet." ElseIf objMsg2.BodyFormat = olFormatPlain Then objMsg2.Body = deletedMsg & objMsg2.Body Else Err.Raise vbObjectError,, "Unknown message text format." End If               End If            End If        End If    Next Exit Sub ErrorHandler: Dim errMsgboxRes As VbMsgBoxResult errMsgboxRes = MsgBox("Error: " & Err.Description, vbOKOnly + vbCritical) End Sub

This is the version for Outlook 2003:

Public Sub DeleteAttachmentsButLeaveTheirFilenamesBehind

On Error GoTo ErrorHandler:

Dim objOL As Outlook.Application Set objOL = CreateObject("Outlook.Application") Dim objSelection As Outlook.Selection Set objSelection = objOL.ActiveExplorer.Selection ' In the first pass, we just count the number of attachments to delete, ' in order to ask for confirmation if necessary.

Dim emailCount As Integer Dim attachmentCount As Integer Dim objMsg1 As MailItem

For Each objMsg1 In objSelection If objMsg1.Class = olMail Then emailCount = emailCount + 1 Dim objAttachments1 As Outlook.Attachments Set objAttachments1 = objMsg1.Attachments Dim msgAttachmentCount1 As Long msgAttachmentCount1 = objAttachments1.Count attachmentCount = attachmentCount + objAttachments1.Count End If   Next Dim msgboxRes As VbMsgBoxResult If emailCount = 0 Then msgboxRes = MsgBox("No e-mails selected.", vbOKOnly + vbCritical) Exit Sub End If   If attachmentCount = 0 Then msgboxRes = MsgBox("No attachments found in " & emailCount & " e-mail(s).", vbOKOnly + vbCritical) Exit Sub End If   If emailCount > 1 Then msgboxRes = MsgBox("Would you like to remove " & attachmentCount & " attachment(s) from " & emailCount & " e-mail(s)?", vbYesNo + vbQuestion + vbDefaultButton2) If msgboxRes = vbNo Then Exit Sub End If   End If

' In the second pass, we remove the attachments. Note that the e-mails could have changed in the meantime. ' However, it's rare to hit that window of opportunity. Dim deletedMsg As String Dim objMsg2 As MailItem

For Each objMsg2 In objSelection If objMsg2.Class = olMail Then ' Open all e-mails we are going to change. Otherwise, if the user closes Outlook, any changes will be discarded. ' See the big comment above for more information. objMsg2.Display Dim objAttachments2 As Outlook.Attachments Set objAttachments2 = objMsg2.Attachments Dim msgAttachmentCount2 As Long msgAttachmentCount2 = objAttachments2.Count If msgAttachmentCount2 > 0 Then deletedMsg = ""

Dim i As Long For i = msgAttachmentCount2 To 1 Step -1 ' One vbCrLf is apparently not enough (does nothing), but two of them do too much (2 line breaks). deletedMsg = "[Attachment deleted: " & objAttachments2.Item(i).FileName & "]" & vbCrLf & vbCrLf & deletedMsg objAttachments2.Item(i).Delete Next i               deletedMsg = deletedMsg & vbCrLf Dim objInsp As Outlook.Inspector Set objInsp = objMsg2.GetInspector If objMsg2.BodyFormat = olFormatHTML Then ' Here we should do HTML escaping. deletedMsg = Replace(deletedMsg, vbCrLf, " ") objMsg2.HTMLBody = " " & deletedMsg & " " & objMsg2.HTMLBody ElseIf objMsg2.BodyFormat = olFormatRichText Then ' I did not manage to edit the RTF format directly yet, because objMsg2.RTFBody ' is not a string, but an array of bytes. Err.Raise vbObjectError,, "Modifying an e-mail in RTF format not supported yet." ElseIf objMsg2.BodyFormat = olFormatPlain Then objMsg2.Body = deletedMsg & objMsg2.Body Else Err.Raise vbObjectError,, "Unknown message text format." End If           End If        End If    Next Exit Sub ErrorHandler: Dim errMsgboxRes As VbMsgBoxResult errMsgboxRes = MsgBox("Error: " & Err.Description, vbOKOnly + vbCritical) End Sub