A user wanted to know how to keep the name of an attachment in a message after using VBA to remove the attachment. Viggo_L 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

Run a script version

This version of the macro is used in a run a script rule. The conversion was simple: change the name of the macro to include myItem as outlook.mailitem inside the parenthesis and remove the lines that loop through with the selected messages.

Sub Delete_attachments_nosave(myItem As Outlook.MailItem)
 
 Dim Response As VbMsgBoxResult
 Response = MsgBox("Do you REALLY want to PERMANENTLY delete all attachments in the incoming messages?" _
 , vbExclamation + vbDefaultButton2 + vbYesNo)
 If Response = vbNo Then Exit Sub
 
 Dim myAttachment As Attachment
 Dim myAttachments As Attachments
 Dim lngAttachmentCount As Long
 
 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 = ""
 
 MsgBox "Done. All attachments were deleted.", vbOKOnly, "Message"
 
 Set myAttachment = Nothing
 Set myAttachments = Nothing
 End Sub