Saving/Deleting All Attachments With One Click

This post is in response to this tweet from petemarcus that was re-tweeted by malcolmcoles.

Dull tweet alert. Microsoft Outlook needs a 'remove all attachments' button as well as 'save all'. Good to get that off my chest.

— petemarcus (@petemarcus) August 26, 2011

While Pete and Malcolm wait for Microsoft to add these capabilities to Outlook they can use the code below to accomplish both tasks. The code is very simple. Here’s how it works. First, it implements a loop that processes all selected items. For each item it processes all attachments. For each attachment, If the attachment isn’t a hidden item, then it either deletes it or saves it. Hidden attachments, those that are embedded in the item (e.g. a graphic in the signature), are not processed. In the save attachments routine I’m using Microsoft Excel’s folder picker dialog-box since Outlook doesn’t have one of its own. This solution should work in Outlook 2007 and later.

Code and Instructions.

Here then is the code for either saving or deleting all attachments. Follow these instructions to add it to Outlook.

1. Start Outlook
2. Press ALT+F11 to open the VB editor
3. If not already expanded, expand Microsoft Office Outlook Objects
4. If not already expanded, expand Modules
5. Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert > Module
6. Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook’s VB Editor window
7. Edit the code as needed. I included comments wherever something needs to or can change
8. Click the diskette icon on the toolbar to save the changes
9. Close the VB Editor

Sub DeleteAllAttachments()
    Dim olkMsg As Object, intIdx As Integer
    For Each olkMsg In Application.ActiveExplorer.Selection
        For intIdx = olkMsg.Attachments.Count To 1 Step -1
            If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                olkMsg.Attachments.Item(intIdx).Delete
            End If
        Next
        olkMsg.Close olSave
        Set olkMsg = Nothing
    Next
End Sub

Sub SaveAllAttachments()
    Const msoFileDialogFolderPicker = 4
    Dim olkMsg As Object, intIdx As Integer, excApp As Object, strPath As String
    Set excApp = CreateObject("Excel.Application")
    With excApp.FileDialog(msoFileDialogFolderPicker)
        .Show
        For intIdx = 1 To .SelectedItems.Count
            strPath = .SelectedItems(intIdx)
        Next
    End With
    If strPath <> "" Then
        For Each olkMsg In Application.ActiveExplorer.Selection
            For intIdx = olkMsg.Attachments.Count To 1 Step -1
                If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                    olkMsg.Attachments.Item(intIdx).SaveAsFile strPath & "\" & olkMsg.Attachments.Item(intIdx).FileName
                End If
            Next
            olkMsg.Close olDiscard
            Set olkMsg = Nothing
        Next
    End If
    Set excApp = Nothing
End Sub

Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
    'Purpose: Determines if an attachment is embedded.'
    'Written: 10/12/2010'
    'Outlook: 2007'
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkAttachment.PropertyAccessor
    IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Usage.

• Select one or more items
• Run the macro DeleteAllAttachments to delete attachments or SaveAllAttachments to save them.

One Click

Running the macros with a single click requires a bit more work. In Outlook 2003 and 2007 we’ll add a button to the toolbar. Outlook 2010 uses the ribbon, so for this version we’ll add a button to the Quick Access Toolbar (QAT).

Outlook 2007. Follow these instructions to add toolbar buttons that run these macros.

Outlook 2010. Follow these instructions to add both macros to the QAT.

Revisions.

• Revision 1

This revision is for Guillaume who asked about two modifications. First, he would like to add a list of the attachments the code has deleted at the bottom of the message. Second, he would like to add a list of the attachments the code has saved, with a hyperlink to the saved attachment, at the bottom of the message. This version uses the same instructions as the original.

Sub DeleteAllAttachments()
    Dim olkMsg As Object, intIdx As Integer, strBuffer As String
    For Each olkMsg In Application.ActiveExplorer.Selection
        For intIdx = olkMsg.Attachments.count To 1 Step -1
            If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                strBuffer = strBuffer & olkMsg.Attachments.Item(intIdx).FILENAME & vbCrLf
                olkMsg.Attachments.Item(intIdx).Delete
            End If
        Next
        Select Case olkMsg.BodyFormat
            Case olFormatHTML
                If Len(strBuffer) > 0 Then
                    strBuffer = Left(strBuffer, Len(strBuffer) - 1)
                    strBuffer = Replace(strBuffer, vbCrLf, "<br>")
                    olkMsg.HTMLBody = olkMsg.HTMLBody & "<p>Removed Attachments & <br><br>" & strBuffer & "</p>"
                End If
            Case Else
                If Len(strBuffer) > 0 Then
                    strBuffer = Left(strBuffer, Len(strBuffer) - 1)
                    olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & "Remove Attachments" & vbCrLf & vbCrLf & strBuffer
                End If
        End Select
        olkMsg.Close olSave
        Set olkMsg = Nothing
    Next
End Sub
 
Sub SaveAllAttachments()
    Const msoFileDialogFolderPicker = 4
    Dim olkMsg As Object, intIdx As Integer, excApp As Object, strPath As String, strBuffer As String
    Set excApp = CreateObject("Excel.Application")
    With excApp.FileDialog(msoFileDialogFolderPicker)
        .Show
        For intIdx = 1 To .SelectedItems.count
            strPath = .SelectedItems(intIdx)
        Next
    End With
    If strPath <> "" Then
        For Each olkMsg In Application.ActiveExplorer.Selection
            For intIdx = olkMsg.Attachments.count To 1 Step -1
                If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                    olkMsg.Attachments.Item(intIdx).SaveAsFile strPath & "\" & olkMsg.Attachments.Item(intIdx).FILENAME
                    strBuffer = strBuffer & "<a href=""" & strPath & "\" & olkMsg.Attachments.Item(intIdx).FILENAME & """>" & olkMsg.Attachments.Item(intIdx).FILENAME & "</a>" & vbCrLf
                End If
            Next
            Select Case olkMsg.BodyFormat
                Case olFormatHTML
                    If Len(strBuffer) > 0 Then
                        strBuffer = Left(strBuffer, Len(strBuffer) - 1)
                        strBuffer = Replace(strBuffer, vbCrLf, "<br>")
                        olkMsg.HTMLBody = olkMsg.HTMLBody & "<p>Saved Attachments & <br><br>" & strBuffer & "</p>"
                    End If
                Case Else
                    If Len(strBuffer) > 0 Then
                        strBuffer = Left(strBuffer, Len(strBuffer) - 1)
                        olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & "Saved Attachments" & vbCrLf & vbCrLf & strBuffer
                    End If
            End Select
            olkMsg.Close olSave
            Set olkMsg = Nothing
        Next
    End If
    Set excApp = Nothing
End Sub
 
Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
    'Purpose: Determines if an attachment is embedded.'
    'Written: 10/12/2010'
    'Outlook: 2007'
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkAttachment.PropertyAccessor
    IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

• Revision 2

I created this revision based a comment I received from Didier. He suggested these two changes

1. Could the macro remember the last folder where files where saved instead of coming back to My Documents folder every time the macro is run.
2. If files already exist in the folder, it should ask if we want to replace them or not.

In order to keep track of the last folder used the macro now creates a post in Outlook’s Drafts folder and writes the path of the last folder selected to it. If the post doesn’t exist, then the macro will create it and store the path to you My Documents folder in it. To handle Didier’s second suggestion I added a test to see if the target folder already has a file with the name of the attachment the script is processing. If it does, then the macro prompts you giving you the choice of overwriting or skipping it. The default option is to skip the file. Note that the macro does not give you the option to change the file’s name.

Use the instructions from the original article to add this code to Outlook.

Sub DeleteAllAttachments()
    Dim olkMsg As Object, intIdx As Integer
    For Each olkMsg In Application.ActiveExplorer.Selection
        For intIdx = olkMsg.Attachments.Count To 1 Step -1
            If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                olkMsg.Attachments.Item(intIdx).Delete
            End If
        Next
        olkMsg.Close olSave
        Set olkMsg = Nothing
    Next
End Sub

Sub SaveAllAttachments()
    '--> Define some constants
    Const msoFileDialogFolderPicker = 4
    
    '--> Define some variables
    Dim olkMsg As Object, _
        olkPos As Outlook.PostItem, _
        intIdx As Integer, _
        excApp As Object, _
        objFSO As Object, _
        strPath As String, _
        strTmp As String
        
    '--> Create a post item in the Drafts folder to store the last folder selected.  If creating it for the first time, then store the path to My Documents in it.
    On Error Resume Next
    Set olkPos = Session.GetDefaultFolder(olFolderDrafts).Items("Last Folder Selected")
    On Error GoTo 0
    If TypeName(olkPos) = "Nothing" Then
        strPath = Environ("USERPROFILE") & "\My Documents"
        Set olkPos = Session.GetDefaultFolder(olFolderDrafts).Items.Add("IPM.Post")
        With olkPos
            .Subject = "Last Folder Selected"
            .BodyFormat = olFormatPlain
            .Body = strPath
            .Save
        End With
    Else
        strPath = olkPos.Body
    End If
    
    '--> Prompt the user for a folder
    Set excApp = CreateObject("Excel.Application")
    With excApp.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strPath
        strPath = ""
        .Show
        For intIdx = 1 To .SelectedItems.Count
            strPath = .SelectedItems(intIdx)
        Next
    End With
    
    '--> If the user selected a folder (i.e. did not click Cancel)
    If strPath <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        olkPos.Body = strPath
        olkPos.Save
        For Each olkMsg In Application.ActiveExplorer.Selection
            For intIdx = olkMsg.Attachments.Count To 1 Step -1
                If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                    strTmp = strPath & "\" & olkMsg.Attachments.Item(intIdx).Filename
                    If objFSO.FileExists(strTmp) Then
                        If MsgBox("A file named " & olkMsg.Attachments.Item(intIdx).Filename & " already exists.  Do you want to overwite it?", vbInformation + vbYesNo + vbDefaultButton2, "Save All Attachments") = vbYes Then
                           olkMsg.Attachments.Item(intIdx).SaveAsFile strTmp
                        End If
                    Else
                        olkMsg.Attachments.Item(intIdx).SaveAsFile strTmp
                    End If
                End If
            Next
            olkMsg.Close olDiscard
            Set olkMsg = Nothing
        Next
    End If
    
    '--> Clean-up objects
    Set excApp = Nothing
    Set olkPos = Nothing
    Set excApp = Nothing
    Set objFSO = Nothing
End Sub

Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
    'Purpose: Determines if an attachment is embedded.'
    'Written: 10/12/2010'
    'Outlook: 2007'
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkAttachment.PropertyAccessor
    IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

• Revision 3

I created this revision for Tommy who asked for a mashup of the functionality in revisions 1 and 2. Tommy prefers revision 2 but would like to add revision 1’s list of saved/deleted items at the bottom of the processed messages.

Use the instructions from the original article to add this code to Outlook.

Option Explicit

Sub DeleteAllAttachments()
    Dim olkMsg As Object, intIdx As Integer, strBuffer As String
    For Each olkMsg In Application.ActiveExplorer.Selection
        For intIdx = olkMsg.Attachments.Count To 1 Step -1
            If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                strBuffer = strBuffer & olkMsg.Attachments.Item(intIdx).Filename & vbCrLf
                olkMsg.Attachments.Item(intIdx).Delete
            End If
        Next
        Select Case olkMsg.BodyFormat
            Case olFormatHTML
                If Len(strBuffer) > 0 Then
                    strBuffer = Left(strBuffer, Len(strBuffer) - 1)
                    strBuffer = Replace(strBuffer, vbCrLf, "<br>")
                    olkMsg.HTMLBody = olkMsg.HTMLBody & "<p>Removed Attachments & <br><br>" & strBuffer & "</p>"
                End If
            Case Else
                If Len(strBuffer) > 0 Then
                    strBuffer = Left(strBuffer, Len(strBuffer) - 1)
                    olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & "Remove Attachments" & vbCrLf & vbCrLf & strBuffer
                End If
        End Select
        olkMsg.Close olSave
        Set olkMsg = Nothing
    Next
End Sub


Sub SaveAllAttachments()
    '--> Define some constants
    Const msoFileDialogFolderPicker = 4
    
    '--> Define some variables
    Dim olkMsg As Object, _
        olkPos As Outlook.PostItem, _
        intIdx As Integer, _
        excApp As Object, _
        objFSO As Object, _
        strPath As String, _
        strTmp As String, _
        strBuf As String
        
    '--> Create a post item in the Drafts folder to store the last folder selected.  If creating it for the first time, then store the path to My Documents in it.
    On Error Resume Next
    Set olkPos = Session.GetDefaultFolder(olFolderDrafts).Items("Last Folder Selected")
    On Error GoTo 0
    If TypeName(olkPos) = "Nothing" Then
        strPath = Environ("USERPROFILE") & "\My Documents"
        Set olkPos = Session.GetDefaultFolder(olFolderDrafts).Items.Add("IPM.Post")
        With olkPos
            .Subject = "Last Folder Selected"
            .BodyFormat = olFormatPlain
            .Body = strPath
            .Save
        End With
    Else
        strPath = olkPos.Body
    End If
    
    '--> Prompt the user for a folder
    Set excApp = CreateObject("Excel.Application")
    With excApp.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strPath
        strPath = ""
        .Show
        For intIdx = 1 To .SelectedItems.count
            strPath = .SelectedItems(intIdx)
        Next
    End With
    
    '--> If the user selected a folder (i.e. did not click Cancel)
    If strPath <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        olkPos.Body = strPath
        olkPos.Save
        For Each olkMsg In Application.ActiveExplorer.Selection
            strBuf = ""
            For intIdx = olkMsg.Attachments.count To 1 Step -1
                If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
                    strTmp = strPath & "\" & olkMsg.Attachments.Item(intIdx).FILENAME
                    If objFSO.FileExists(strTmp) Then
                        If MsgBox("A file named " & olkMsg.Attachments.Item(intIdx).FILENAME & " already exists.  Do you want to overwite it?", vbInformation + vbYesNo + vbDefaultButton2, "Save All Attachments") = vbYes Then
                           olkMsg.Attachments.Item(intIdx).SaveAsFile strTmp
                           strBuf = strBuf & "<a href=""" & strTmp & """>" & olkMsg.Attachments.Item(intIdx).FILENAME & "</a>" & vbCrLf
                        End If
                    Else
                        olkMsg.Attachments.Item(intIdx).SaveAsFile strTmp
                        strBuf = strBuf & "<a href=""" & strTmp & """>" & olkMsg.Attachments.Item(intIdx).FILENAME & "</a>" & vbCrLf
                    End If
                End If
            Next
            Select Case olkMsg.BodyFormat
                Case olFormatHTML
                    If Len(strBuf) > 0 Then
                        strBuf = Left(strBuf, Len(strBuf) - 1)
                        strBuf = Replace(strBuf, vbCrLf, "<br>")
                        olkMsg.HTMLBody = olkMsg.HTMLBody & "<p>Saved Attachments<br><br>" & strBuf & "</p>"
                    End If
                Case Else
                    If Len(strBuf) > 0 Then
                        strBuf = Left(strBuf, Len(strBuf) - 1)
                        olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & "Saved Attachments" & vbCrLf & vbCrLf & strBuf
                    End If
            End Select
            olkMsg.Close olSave
            Set olkMsg = Nothing
        Next
    End If
    
    '--> Clean-up objects
    Set excApp = Nothing
    Set olkPos = Nothing
    Set excApp = Nothing
    Set objFSO = Nothing
End Sub

Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
    'Purpose: Determines if an attachment is embedded.'
    'Written: 10/12/2010'
    'Outlook: 2007'
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkAttachment.PropertyAccessor
    IsHiddenAttachment = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x7ffe000b")
    On Error GoTo 0
    Set olkPA = Nothing
End Function