Outlook macro that will strip/permanently delete email attachments

[Castillb]

Hello everyone,

I'm looking for an Outlook macro that would strip out and permanently delete attachments from an email message or group of selected emails. I was able to locate the following script, but I just want to make sure that this script is not saving the attachment anywhere.

Just for my own personal learning, if this strip does permanently deletes the attachments. What exactly happens to them?

I'm using Outlook 2007...



Sub RemoveAttachments()
Dim selectedMailItem As Outlook.MailItem
Dim currentAttachment As Outlook.Attachment
Dim i As Integer
For Each selectedMailItem In ThisOutlookSession.ActiveExplorer.Selection
'Remove attachments until there are none left
While selectedMailItem.Attachments.Count > 0
selectedMailItem.Attachments.Remove (1)
Wend
selectedMailItem.Save
Next
End Sub

[Charlize]

Take a look at this coding. Added some notes why something is done. Not saying this is the best coding but takes other things that might happen in consideration to. To answer your question, the attachments are gone, no way to get them back.

Option Explicit
Option Compare Text

Sub RemoveAttachments()
'the mailmessage
Dim selectedMailItem As Outlook.MailItem
'mailmessage counter, attachment counter
Dim counter As Long, attachcount As Long


'check if something is selected
If ThisOutlookSession.ActiveExplorer.Selection.Count > 0 Then
'set the counter to the selected messages
counter = ThisOutlookSession.ActiveExplorer.Selection.Count
'loop through messages from the bottom to top (reverse)
For counter = counter To 1 Step -1
'check if active message is a mailmessage, could be request, task ...
If ThisOutlookSession.ActiveExplorer.Selection(counter).Class = olMail Then
'appoint the active message to an object defined as mailitem
Set selectedMailItem = ThisOutlookSession.ActiveExplorer.Selection(counter)
'loop through attachments from highest to lowest
attachcount = selectedMailItem.Attachments.Count
If attachcount > 0 Then
For attachcount = attachcount To 1 Step -1
'Remove attachments until there are none left
selectedMailItem.Attachments.Remove (attachcount)
Next attachcount
End If
'save the new message
selectedMailItem.Save
End If
Next counter
End If
End Sub