Saving/Deleting All Attachments With One Click


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

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
Advertisements

148 comments on “Saving/Deleting All Attachments With One Click

  1. David Lee,
    You seem to be the guy for reply’s on this page and I am wondering if you can help me out?
    I am in the construction industry and I get a lot of emails that come in and I filter them to my outlook submittals folder. This folder takes up the majority of my outlook mailbox and I want to run this script to do the following:
    On my submittals folder only, for the emails I select/highlight only:
    1. Save the attachment when I push the save all attachments button, have them all go to this folder: C:\Users\Txxxx\Documents\oLSubmittal_Attach
    2. Remove all the attachments of the emails I select/Highlight only when I push the remove all attachments, as a 2nd step, dont want it combined, need a separate button.
    3. Add the link at the bottom of each email for the saved attachments and list the deleted attachments.
    4. when I forward the email after I saved/removed the attachment, have it pull up the attachment and include it with that forwarded email from the same folder above.
    could you post the VBA script to do this? I have tried a few iterations of the ones above and others from online, but I keep getting poor results.
    TIA.

    • Hi, Tom.

      I’ll help if I can. Requirements 1 through 3 don’t pose any problem. They’re all easily done. Requirement 4 is a bit more challenging, though not impossible. From a scripting perspective, the easiest way to handle requirement 4 is to add another button for reattaching saved attachments before forwarding the message. While that’s better script-wise, it’s not as convenient for you. You’d have to remember to use this additional button to forward messages with saved attachments while continuing to use Outlook’s built-in Forward button to forward all other messages. The alternative is to design a way to detect that the message being forwarded has saved attachments and reattach them as Outlook sends it. I’ll need to do some testing to see if I can come up with a way to do that. I’ll be back in touch as soon as I know one way or the other.

    • Hi, ND.

      Remove this line along with the corresponding “End If” statement.

      If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
      
    • Thanks for the quick reply, unfortunately I should have specified that the embedded image is 1) in a RSS message and 2) a hyperlinked image (ex. “https://hbr.org/resources/images/article_assets/2016/05/may16-04-600681903.jpg.” Removing the link doesn’t remove these images. Thanks!

    • Hi, ND.

      That’s completely different. The images in RSS feed posts aren’t attachments. They are HTML image tags. That’s why the code doesn’t work. Here’s a solution that removes all HTML image tags from the selected items. Add this code to Outlook, then select one or more RSS feed items and run the RemoveImageTagsFromRSSFeedItems macro.

      Sub RemoveImageTagsFromRSSFeedItems()
          Dim olkPos As Outlook.PostItem
          For Each olkPos In Application.ActiveExplorer.Selection
              olkPos.HTMLBody = RemoveImageTags(olkPos.HTMLBody)
              olkPos.Save
          Next
          Set olkPos = Nothing
      End Sub
      
      Function RemoveImageTags(strHTM As String) As String
          Dim objRex As Object
          Set objRex = CreateObject("VBScript.RegExp")
          With objRex
              .Global = True
              .IgnoreCase = True
              .Pattern = "<IMG[^>]+>"
              RemoveImageTags = .Replace(strHTM, "")
          End With
          Set objRex = Nothing
      End Function
      
  2. Hello all,

    I hope you are doing great.
    Is there a way to modify the macro so it deletes only *.pdf files?

    Thank you in advance!

    Best regards,
    Peter

    • Hi, Peter.

      Yes, that’s possible. Replace the DeleteAllAttachments subroutine from the original post with the version below.

      Sub DeleteAllAttachments()
          Dim olkMsg As Object, intIdx As Integer, objFSO As Object
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          For Each olkMsg In Application.ActiveExplorer.Selection
              For intIdx = olkMsg.Attachments.Count To 1 Step -1
                  Select Case LCase(objFSO.GetExtensionName(olkMsg.Attachments.Item(intIdx)))
                      Case "pdf"
                          olkMsg.Attachments.Item(intIdx).Delete
                  End Select
              Next
              olkMsg.Close olSave
              Set olkMsg = Nothing
          Next
      End Sub
      
    • David,
      Is there a way so that the attachment is saved, listed on email, then removed from email? It seems as though the code to remove and then delete is two steps.
      Thank you.

    • Hi, Rick.

      Yes, that’s possible. The original code addressed two separate actions: saving or removing. It wasn’t written with the idea of doing both. It was one or the other. If you want to save and delete, then here’s a version that does both in one pass.

      Sub SaveAndDeleteAllAttachments()
          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
                          olkMsg.Attachments.Item(intIdx).Delete
                      End If
                  Next
                  olkMsg.Close olDiscard
                  Set olkMsg = Nothing
              Next
          End If
          Set excApp = Nothing
      End Sub
      
  3. Hello,

    I know this post is old by I am hoping you’re still around to see comments. When I copy the code into the box it does not preserved the formatting and everything ends up in a mess. Am I doing something wrong? I’m completely new to this so maybe it’s something really obvious…

    Thanks for any help you can give

    • Hi, Sarah.

      That happens sometimes. The best way to copy the code is to double-click a word in the code box. That should select all the code. You can then copy and paste like normal. That seems to preserve the formatting, or at least it does for me. Please try that and let me know if it works.

  4. Hi David,
    Thank you for sharing this code. It will also save me a ton of time. I wonder if you would be willing to give some advice on how to do the following with your code.
    1. Make it so it can be used in the Rules section (i.e. visible as script). I found the code (item As Outlook.MailItem) to add to the marco header and it showed up as a script option, but the code no longer works. Is there anyway to make it available for rules?
    2. Can a shortcut key option be added (and customized) so I could quickly execute the code?
    I’m running Outlook 2010
    Thanks for your help and expertise!

    • Hi, Mike.

      I’ve modified the code so it will work from a rule. As part of that modification I removed the ability to select the folder the code saves attachments to. Having to select a folder for each message that arrives would be a problem, especially if you were working on something in Outlook when a message arrived and triggered the script. In place of selecting a folder for each message I’ve hard-coded the save-to folder you can set it to whatever you want, but it’s one folder for all messages. That brings up another issue: duplicate attachment names. This version of the code doesn’t handle duplicates. It simply overwrites a file with the same name.

      I also added two new macros so you can run both the save and the delete from a button on the QAT (quick action toolbar).

      'On the next line edit the path to the folder you want to save attachments to
      Const SAVE_TO_PATH = "c:\users\mike\documents"
      
      Sub CallDeleteAllAttachments()
          DeleteAllAttachments Application.ActiveExplorer.Selection(1)
      End Sub
      
      Sub CallSaveAllAttachments()
          SaveAllAttachments Application.ActiveExplorer.Selection(1)
      End Sub
      
      Sub DeleteAllAttachments(Item As Outlook.Mailitem)
          Dim intIdx As Integer
          For intIdx = Item.Attachments.Count To 1 Step -1
              If Not IsHiddenAttachment(Item.Attachments.Item(intIdx)) Then
                  Item.Attachments.Item(intIdx).Delete
              End If
          Next
          Item.Close olSave
      End Sub
       
      Sub SaveAllAttachments(Item As Outlook.Mailitem)
          Dim intIdx As Integer
          For intIdx = Item.Attachments.Count To 1 Step -1
              If Not IsHiddenAttachment(Item.Attachments.Item(intIdx)) Then
                  Item.Attachments.Item(intIdx).SaveAsFile SAVE_TO_PATH & "\" & Item.Attachments.Item(intIdx).FileName
              End If
          Next
          Item.Close olDiscard
      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
      
    • Dear David,

      Thank you for the code. I saw you have some version: original, revision 1, revision 2, revision 3 and your answer to Mike (new code). Actually how we put the code: original + revision1 + revision2 + revision3 + new code? Or else? Or maybe you have new code that covers all revisions.

      Thank you.

    • Hi, Rahmansyah.

      No, I don’t have code that covers all the revisions you mentioned. I can combine them, but to do so I’d need to know what features you want from each one.

  5. Hi. Not sure if you are still monitoring this.. An old post, but still works on latest outlook versions too 🙂
    I have an error when I try to apply the utility to a large number of messages in one go (long overdue housekeeping). Seems to go wrong around 250.

    It says “The Server Administrator has limited the number of messages you can have open simultaneously…”. plus some other stuff on suggested fixes. The code does seem to be closing each message in turn so not sure why this would be.
    Any ideas…. ?

    Mark W

    • Hi, Mark.

      Yes, I’m still monitoring.

      Are you using the original version of the code or one of the revisions? If a revision, which one? Are you using Outlook in Cached Mode?

    • Hi
      It’s Outlook 201, running with Cache Mode on – though I can turn it off temporarily if that’s a problem.

      I am using the original code listing, and have added an Inbox and IF statement to only remove attachments which match the specified string.

      Mark

    • Hi, Mark.

      No, cached mode isn’t a problem. Based on the error I was thinking that Outlook might not be using cached mode and that the error was a result in a delay between the script closing a message and the server recognizing that it’s been closed. Are the messages you’re processing in your mailbox or a shared mailbox?

  6. David this is a great macro, thank you very much!

    I am using Revision 3 but have a small issue. If I’m trying to save an attachment when there is already an attachment with that name, I get the notification that states if I would like to overwrite it or not. When I click no, it does not prompt me to rename this file.

    Could you please help me either add code to rename this file or add code to just add a number to the end of the file such as file(2).xlsx? Thank you.

    • I found a fix to this issue but have another problem. When I delete attachments to multiple emails, after ‘Removed Attachments’ it lists every attachment that was deleted in every email.

      Any suggestions would be great.

    • Joel,

      I don’t doubt what’s happening, but I don’t see how it’s possible. Line #80 of the code wipes that variable out as it processes each selected message.

  7. I stumbled upon this macro and love it. I ran into an issue with embedded image files. It throws up a runtime error ‘-2147467259 (80004005)’ Outlook cannot perform this action on this type of attachment. I understand the problem but do not know why this is a problem so troubleshooting is a shot in the dark. Any suggestions on where to point me in the right direction. I am using revision 3. Debug points to the second line here
    If Not IsHiddenAttachment(olkMsg.Attachments.Item(intIdx)) Then
    strBuffer = strBuffer & olkMsg.Attachments.Item(intIdx).FileName & vbCrLf
    olkMsg.Attachments.Item(intIdx).Delete
    End If

    • I am using Outlook 2013 and the messages I believe are HTML..i know how ot change the type of message i send, but don’t know how to confirm the type of message that i receive. The error occurs when i image (or maybe a powerpoint slide) is pasted into the body of an email. If the macro could just skip over these images and not error out it would much better than throwing up the debug box and forcing me to unselect the offending message and then run the macro again. In any event the macro is AWESOME and this is only a minor inconvenience that i will gladly work around
      Scott

    • Hi, Scott.

      You can see what format a message is in by opening a message and looking at the title of the window it appears in. The message format appears in parenthesis after the word “Message”. The macro IS designed to skip over embedded items (e.g. a graphic/picture in the message) which in Outlook are known as “hidden attachments”. Such graphics are actually attachments, but they don’t appear in the list of attachments to the message because Outlook knows that they are an embedded item and hides them from that list. The question is, why isn’t the code designed to detect these hidden attachments doing its job? My first thought is that the messages in question are in Rich Text format. Rich Text format does some things differently. That’s why I asked about the message format. My second thought is that something changed in Outlook 2013 causing the detection code to fail. I’ll check that and get back to you. In the meantime, please check the format of the messages and let me know what it is.

    • You are correct – the messages that cause the Debug dialog are all Rich Text. I will keep an eye out to see if this error occurs on any other mail format but all the items I was able to reproduce the error on were rich text.

    • Scott,

      Rich-text handles things a bit differently. That format isn’t typically used a lot. I’ll see about modifying the code to handle it too.

    • Actually scratch that – not all the errors occur on Rich Text. I have a HTML message that also fails.

      Select Case olkMsg.BodyFormat
      Case olFormatHTML
      this line–> strBuffer = Left(strBuffer, Len(strBuffer) – 1)
      strBuffer = Replace(strBuffer, vbCrLf, “”)
      olkMsg.HTMLBody = olkMsg.HTMLBody & “Removed Attachments & ” & strBuffer & “”
      Case Else
      strBuffer = Left(strBuffer, Len(strBuffer) – 1)
      olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & “Remove Attachments” & vbCrLf & vbCrLf & strBuffer

      The particular message does not have any “visible” attachments, but has an embedded image.

    • Scott,

      Please replace the IsHiddenAttachment function you have now with the version below. Once you’ve done that, please try the solution again and let me know what you see in the pop-up dialog-box that this version displays.

      Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
          ' Purpose: Determines if an attachment is a hidden attachment.
          ' Written: 7/12/2012
          ' Author:  David Lee
          ' Outlook: 2007 and later
          Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
          Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
          On Error Resume Next
          Set olkPA = olkAtt.PropertyAccessor
          varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
          If Err.Number <> 0 Then
              MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Is Hidden Attachment"
          Else
              MsgBox "Attachment: " & olkAtt.FILENAME & vbCrLf & "varTemp: " & varTemp, vbInformation + vbOKOnly, "Is Hidden Attachment"
          End If
          IsHiddenAttachment = (varTemp <> "")
          On Error GoTo 0
          Set olkPA = Nothing
      End Function
      
    • When run on a Rich Text message this is the error
      Run-time error ‘-2147467259 (80004005)’: Outlook cannot perform this action on this type of attachment.

      When run on HTML The Error message is
      Run-time error ‘5’:
      Invalid procedure call or argument

      The HTML message brings up a dialog box “Attachment:XXXX, VarTemp: imageXXX.jpg@XXXXX” but the Rich text message does not – just errors out.

    • Scott,

      Could you share those two messages with me so I can look at the underlying message properties and try to figure out what’s going on? If you can, then I’ll send you an email and you can reply with those two messages attached.

    • I have an email I can send you – just a dummy HTML email that causes the error. I will see about also creating a dummy Rich Text email also

    • Scott,

      I ran both of the test messages you provided through the code here on my computer (Office 2013). The code correctly detected that the image in the HTML message is a hidden attachment. The code did not work for the Rich Text message. I’m working to fix that. For the HTML message, when you run the code against it and get the error, what line does the error occur on?

    • Error on HTML is
      Run-time error ‘5’:
      Invalid procedure call or argument

      The line of code that it highlighted during debug is “strBuffer = Left(strBuffer, Len(strBuffer) – 1)” first line under case olFormatHTML

    • Hi, Scott.

      There are only two ways that error could occur: the message does not have any attachments, the message only has hidden attachments. We can handle both conditions by adding a test to see if the variable strBuffer is blank. If it isn’t, then insert the list of saved/removed attachments. If it is, then skip over that part. I’ve modified the code in rev 1 accordingly. Please download and use it in place of the code you have now.

    • Works like a champ on the HTML messages….for RTF formatted messages i still see runtime error ‘-2147467259 (80004005). Debug points to line 6: strBuffer = strBuffer & olkMsg.Attachments.Item(intIdx).FileName & vbCrLf

      No need to continue and debug this on my account.

    • Great script! Thx.

      A tiny bug (I’ve nobody mentioned it before (?) ):
      In the script the string variable strBuf is mixed up with StrBuffer. StrBuffer does not exist….

    • David – I had another thought. Again if this is just an issue I face, probably not worth spending time on it. But I still have that error with rich text messages…Looks like it is when images are pasted in to the email (hidden attachments). Maybe they all would have the same name or maybe they don’t have a file name at all? In any event…is there a way just compress those pictures vs. delete them?
      Scott

    • I was thinking convert from whatever format to jpg at 72 dpi? I get a daily email that is 5mb and it is rich text format with maybe 5 embedded images. There is no way each image should be 1mb. Ironically these are also some of the images that cause the error in the delete attachments macro so I have to manually go in and edit message the. delete the images.

    • Scott,

      I don’t think that’ll work. There’s no way I know of to compress the pic in place. The only way I know of to do that would be to detach each image, convert it to 72dpi jpg, and reattach it. Doing that would lose the pic’s position, lose any links associated with an image, and possibly more.

  8. The macro is fantastic congratulations, save me a lot of time every day!
    I tried to adapt Revision 3 unsuccessfully to just ask me where I want to save the attachments the first time and after saving it should remove all email attachments.
    That is, a macro that saves all attachments (list of saved/deleted items at the bottom of the email) and then deletes them without asking me where I want to save them (only the first time). Is it possible?

    thanks a lot!

    • Hi, Miguel.

      Thanks. I’m glad the macro is useful to you.

      I’m not sure I understand. Are you saying that you’d like the macro to ask you where to save the attachments to the first time you run it and then remember that location from then on?

    • I have already adapt the code to:
      – just ask me where I want to save the attachments the first time, then always record in that folder
      – Save and remove attachments all in one

      But now I have difficulty in solving the problem of duplicate file names. To solve this I am trying to assign the file name to be always “original file name + current date and time” (exemple “original file name”271120141153”).

      this is what I have so far:

      I have Error in this line: strTmp = strPath & “\” & olkMsg.Attachments.Item(intIdx).FileName & Format(Now(), “yyyymmddhhmmss”)

      [Code]
      Sub TEST2SaveandremoveAllAttachments()

      ‘–> 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
      If TypeName(olkPos) = “Nothing” Then
      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
      Else

      End If
      ‘–> 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 & Format(Now(), “yyyymmddhhmmss”)
      olkMsg.Attachments.Item(intIdx).SaveAsFile strTmp
      strBuf = strBuf & “” & olkMsg.Attachments.Item(intIdx).FileName & “” & vbCrLf
      olkMsg.Attachments.Item(intIdx).Delete
      End If
      Next
      Select Case olkMsg.BodyFormat
      Case olFormatHTML
      strBuf = Left(strBuf, Len(strBuf) – 1)
      strBuf = Replace(strBuf, vbCrLf, “”)
      olkMsg.HTMLBody = olkMsg.HTMLBody & “Anexos Guardados e Removidos:” & strBuf & “”
      Case Else
      strBuf = Left(strBuf, Len(strBuf) – 1)
      olkMsg.Body = olkMsg.Body & vbCrLf & vbCrLf & “Anexos Guardados e Removidos:” & vbCrLf & vbCrLf & strBuf
      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
      Set olkMsg = Nothing

      End Sub

      Private Function IsHiddenAttachment(olkAttachment As Outlook.Attachment) As Boolean
      ‘Determinar se o anexo está no corpo do email. 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

      [Code\]

    • Hi David,

      I found how to work around the problem.
      I could not get the “original file name + current date and time” but I managed to get “current date and time + original file name”

      Once again thanks for the fantastic macro!

  9. Pingback: Outlook Saving Attachments With Same Name - ORG.org

  10. Pingback: VBA Outlook | Pearltrees

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s