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.
- Open the VB Editor using Alt+F11.
- Right click on Project1 and choose Insert > Module.
- Paste the code into the module.
- 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
Can something like this be set up to run on sent items in a shared mailbox in Office 365?
if the mailbox is open in your profile, yes, You will need to use an itemadd macro and watch the folder.
you need to watch the folder - an example is here -
https://www.slipstick.com/outlook/archive-outlook/save-incoming-messages-hard-drive/
and to set the shared mailbox, you need this code
https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#shared
The macro in the attached file should do it, but i did not test it. Change maryc to the mailbox alias.
Hi
I just tried out your script (to use as an outlook rule) and it not removing images that are included in the HTML body of an email and not as an attachment that outlook can see.
This is taking place on outlook 2016.
Do you know why this would happen?
Thank you :)
Diane,
I cooked up my own VBA code to do this awhile back, and just found your example - I wish I had found it earlier!
Anyway, when I substituted one chunk of your code into mine, the section that adds the list of what attacments were deleted, it changes the font of the message. Any idea why? Here's the pertinent section of my script (I can post the entire thing if needed)
maybe the p tag makes a difference?
myItem.HTMLBody = myItem.HTMLBody & "
" & _
"The file(s) removed were: " & strFile & "
"
End If
(That's my best guess without seeing your full code. )
THANKS !!!! This was a huge help!!! It's actually a work-around type thing, but I'll take it ! For years, I've been using macros in MSO to remove attachments and move them to a designated folder - I have been having a TON of problems doing this in v2013, WIN7 OS - when I try to run my macro, it freezes up. I didn't realize how easy it is to move attachments (just click and drag) to explorer - so I just move (copy) my attachments to the destination folder, and then run this macro - LOVE it !
Hello,
I use this macro a lot. It does not seem to work in Outlook 2016. Is there a way to make it work? Thanks
It definitely should work. Step through the macro and see if it hits each line it should touch.
HI Diane, I've run a VBA macro to save all the attachments in an Outlook folder and then delete the attachment from each e-mail. Is there a way to UN-delete all these attachments. The reason is that the macro did not copy attachments to the folder it was supposed to.
No, if the messages were saved, the attachments were deleted and they are gone. You could look in the securetemp folder - if you opened any recently, they might be there. It should be at shell:cache (type or paste that in the address bar of windows explorer) in a folder called Content.Outlook.
Thanks very much! the script is really useful.
Please help! How do I modify this so it becomes a selected script in an outlook rule?
i.e. when a message comes into the Inbox with x in body text and attachment, delete (don't save) the attachment?
Am at wits end with this one - thanks!
you need to add item as outlook.mailitem inside the () in the file name, or to make it easier for this macro, use myItem as outlook.mailitem. The remove the selection lines and Next at the end.
I added a run a script macro at the end of the article.