Export or Strip Email Attachments in Outlook

Intro

I've seen a few requests floating around for scripts that will export or strip attachments out of emails, and so far have never encountered any high quality implementations of this feature, so I created this method with a little flavor. Whether you just want an easy way to save all attachments somewhere on your computer, or you're doing a bulk reduction of your inbox size, this script should satisfy your needs.

All you need to do is select the emails you want to export or remove attachments from, and click your new "Export Attachments" button:

Specify your file path:

Choose whether or not you want to remove attachments from the original message(s):

(Don't worry about overwriting same-named files, I have you covered):

And presto! Your attachments have been saved to the desired location:

And if you chose to strip attachments, your emails will now be conveniently prepended with the files it used to contain, their size, and a link to the path where they were saved:



Here's how you make yourself an Export Attachments feature in Outlook

1. Insert a New Module

You're going to be making a VBA macro for going through messages and attachments. To do this, you need to open up the VBA project for your Outlook (by pressing Alt+F11). When it opens, your window will look similar to the one in the screen shot below. Then, right click your project on the left, and click Insert, Module, as shown:

2. Paste in the Macro Code

The hard work has all been done for you :)
The code below takes care of all the features describe above (and more). Just copy paste it into the window, and you're almost ready to go! The code to copy in is below:

Option Explicit
                      
                      Public Sub ExportAttachments()
                          Dim objOL As Outlook.Application
                          Dim objMsg As Object
                          Dim objAttachments As Outlook.Attachments
                          Dim objSelection As Outlook.Selection
                          Dim i As Long, lngCount As Long
                          Dim filesRemoved As String, fName As String, strFolder As String, saveFolder As String, savePath As String
                          Dim alterEmails As Boolean, overwrite As Boolean
                          Dim result
                          
                          saveFolder = BrowseForFolder("Select the folder to save attachments to.")
                          If saveFolder = vbNullString Then Exit Sub
                          
                          result = MsgBox("Do you want to remove attachments from selected file(s)? " & vbNewLine & _
                          "(Clicking no will export attachments but leave the emails alone)", vbYesNo + vbQuestion)
                          alterEmails = (result = vbYes)
                          
                          Set objOL = CreateObject("Outlook.Application")
                          Set objSelection = objOL.ActiveExplorer.Selection
                          
                          For Each objMsg In objSelection
                              If objMsg.Class = olMail Then
                                  Set objAttachments = objMsg.Attachments
                                  lngCount = objAttachments.Count
                                  If lngCount > 0 Then
                                      filesRemoved = ""
                                      For i = lngCount To 1 Step -1
                                          fName = objAttachments.Item(i).FileName
                                          savePath = saveFolder & "\" & fName
                                          overwrite = False
                                          While Dir(savePath) <> vbNullString And Not overwrite
                                              Dim newFName As String
                                              newFName = InputBox("The file '" & fName & _
                                                  "' already exists. Please enter a new file name, or just hit OK overwrite.", _
                                                  "Confirm File Name", fName)
                                              If newFName = vbNullString Then GoTo skipfile
                                              If newFName = fName Then overwrite = True Else fName = newFName
                                              savePath = saveFolder & "\" & fName
                                          Wend
                                          
                                          objAttachments.Item(i).SaveAsFile savePath
                                          
                                          If alterEmails Then
                                              filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _
                                                                                      formatSize(objAttachments.Item(i).size) & ") " & _
                                                  "<a href=""" & savePath & """>[Location Saved]</a>"
                                              objAttachments.Item(i).Delete
                                          End If
                      skipfile:
                                      Next i
                                      
                                      If alterEmails Then
                                          filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>"
                                          
                                          Dim objDoc As Object
                                          Dim objInsp As Outlook.Inspector
                                          Set objInsp = objMsg.GetInspector
                                          Set objDoc = objInsp.WordEditor
                      
                                          objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody
                                          objMsg.Save
                                      End If
                                  End If
                              End If
                          Next
                          
                      ExitSub:
                          Set objAttachments = Nothing
                          Set objMsg = Nothing
                          Set objSelection = Nothing
                          Set objOL = Nothing
                      End Sub
                      
                      Function formatSize(size As Long) As String
                          Dim val As Double, newVal As Double
                          Dim unit As String
                          
                          val = size
                          unit = "bytes"
                          
                          newVal = Round(val / 1024, 1)
                          If newVal > 0 Then
                              val = newVal
                              unit = "KB"
                          End If
                          newVal = Round(val / 1024, 1)
                          If newVal > 0 Then
                              val = newVal
                              unit = "MB"
                          End If
                          newVal = Round(val / 1024, 1)
                          If newVal > 0 Then
                              val = newVal
                              unit = "GB"
                          End If
                          
                          formatSize = val & " " & unit
                      End Function
                      
                      'Function purpose:  To Browser for a user selected folder.
                      'If the "OpenAt" path is provided, open the browser at that directory
                      'NOTE:  If invalid, it will open at the Desktop level
                      Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String
                          Dim ShellApp As Object
                          Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt)
                      
                          On Error Resume Next
                          BrowseForFolder = ShellApp.self.Path
                          On Error GoTo 0
                          Set ShellApp = Nothing
                           
                          'Check for invalid or non-entries and send to the Invalid error handler if found
                          'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid
                          Select Case Mid(BrowseForFolder, 2, 1)
                              Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
                              Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
                              Case Else: GoTo Invalid
                          End Select
                           
                          Exit Function
                      Invalid:
                           'If it was determined that the selection was invalid, set to False
                          BrowseForFolder = vbNullString
                      End Function
                      
                      Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String
                          Dim ShellApp As Object
                          Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt)
                          
                          On Error Resume Next
                          BrowseForFile = ShellApp.self.Path
                          On Error GoTo 0
                          Set ShellApp = Nothing
                           
                          'Check for invalid or non-entries and send to the Invalid error handler if found
                          'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid
                          Select Case Mid(BrowseForFolder, 2, 1)
                              Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
                              Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
                              Case Else: GoTo Invalid
                          End Select
                           
                          Exit Function
                      Invalid:
                           'If it was determined that the selection was invalid, set to False
                          BrowseForFile = vbNullString
                      End Function
                      

Select all Open in new window

When you've pasted it in, everything should look like this. The code is pretty straightforward, so those of you who like to dig in should be able to understand and customize it at will:

3. Add a Button for Your Macro

Now you can close down the Microsoft Visual Basic window. You've done the hard part. Next we want to add the macro to the toolbar so that you can use it conveniently. Right click on a blank area of the toolbar as shown, and click "Customize...". This will bring up the Outlook Customize Toolbars dialogue.

4. Drag your Macro Onto the Toolbar

You have to find your macro and drag it onto the Toolbar now. Switch to the "Commands" tab in the dialogue, and select "Macros" from the list on the left. You should see "ExportAttachments" macro there. Select it and drag it to wherever you want it on your toolbar:

5. Rename the Button

You probably don't like the ugly name Outlook has given your button, so go ahead and rename it. To do this, click the "Rearrange Commands" button at the bottom of the dialogue we have open (I know - pretty unintuitive). A new dialogue will open. Click the "Toolbar" option button (instead of "Menu Bar") and find the new button you just created. When you find it, select it and click the "Modify Selection" button. Here, you can rename it to whatever you want. Here's an illustration:

If you want, you can give your button a shortcut by inserting an ampersand (&) in front of the letter you want to be the shortcut. Then when you press Alt+'That Letter', it will trigger the button. Careful, if you chose a letter that is already a shortcut (like E for the 'Edit' menu item) then you'll have to press Alt+E+E(again) to cycle through to your button.

6. Test it out!

Now test it out! Select one or more emails, click the button, and save out your attachments. Isn't that sharp?


A few extra notes


One other thing you might want to consider is changing the icon of your button. I'm sure you've noticed that that nice icon on the first page doesn't appear on its own. I created that in the same place as I renamed the button. After clicking "Modify Selection", click "Modify button icon..." and you will get a window where you can specify your own icon. This is how I designed mine:


Enjoy, and if you found this article handy, let me know and click "Yes" at the top of the page!

--
Alain Bryden

PS: If you're curious about that 'Archive Message(s)' button on my toolbar, you can check out my article about it here: How to make an 'Archive' button in Outlook
Other articles by me.