Delete attachments from messages

Viggo_L wanted to know how to keep the name of an attachment in a message after using VBA to remove the attachment. He had the VBA code to remove the attachment but needed help saving the attachment name to the message.

Solution: add the attachment name to a string as you loop through the attachments and remove them:

 
While lngAttachmentCount > 0
strFile = myAttachments.Item(1).FileName & "; " & strFile

Then write the string to the bottom of the message:

If myItem.BodyFormat <> olFormatHTML Then
 myItem.Body = myItem.Body & vbCrLf & _
 "The file(s) removed were: " & strFile
 Else
 myItem.HTMLBody = myItem.HTMLBody & "<p>" & _
 "The file(s) removed were: " & strFile & "</p>"
 End If

Clear the string value before processing the next selected message:

myItem.Save
  strFile = ""
 Next

Delete attachments but save filenames to message

To use this code, you need to set macro security to Low. In Outlook 2010 or 2013, this is done in File, Options, Trust Center.

1. Open the VB Editor using Alt+F11.
2. Right click on Project1 and choose Insert > Module.
3. Paste the code into the module.
4. Select one or more messages and run the macro.

Tip: to test the macro, select some messages that have attachments and copy them to a new folder. Select all of the messages in the new folder, press Ctrl+C then Ctrl+V several time to make copies of the messages. Select some of the messages to test the macro. When you are satisfied it works as expected, delete the folder.

Sub Delete_attachments_nosave()

 Dim Response As VbMsgBoxResult
 Response = MsgBox("Do you REALLY want to PERMANENTLY delete all attachments in all SELECTED mails?" _
 , vbExclamation + vbDefaultButton2 + vbYesNo)
 If Response = vbNo Then Exit Sub

 Dim myAttachment As Attachment
 Dim myAttachments As Attachments
 Dim selItems As Selection
 Dim myItem As Object
 Dim lngAttachmentCount As Long

 ' Set reference to the Selection.
 Set selItems = ActiveExplorer.Selection

 ' Loop though each item in the selection.
 For Each myItem In selItems
 Set myAttachments = myItem.Attachments

 lngAttachmentCount = myAttachments.count

 ' Loop through attachments until attachment count = 0.
 While lngAttachmentCount > 0
 strFile = myAttachments.Item(1).FileName & "; " & strFile
 myAttachments(1).Delete
 lngAttachmentCount = myAttachments.count
 Wend
 
 
If myItem.BodyFormat <> olFormatHTML Then
 myItem.Body = myItem.Body & vbCrLf & _
 "The file(s) removed were: " & strFile
 Else
 myItem.HTMLBody = myItem.HTMLBody & "<p>" & _
 "The file(s) removed were: " & strFile & "</p>"
 End If
 

 myItem.Save
  strFile = ""
 Next

 MsgBox "Done. All attachments were deleted.", vbOKOnly, "Message"

 Set myAttachment = Nothing
 Set myAttachments = Nothing
 Set selItems = Nothing
 Set myItem = Nothing
 End Sub

Related Posts:

1. How to remove attachments from selected messages in Microsoft Outlook'

   Remove attachments from messages
2. Use this macro to send an attachment to email addresses in the To line

   VBA: No attachments to CC'd recipients
3. 

   Save and Open an Attachment using VBA
4. The following code works in Outlook 2000 and up. It saves the attachme

   Save Attachments to the hard drive