UPDATE OCT 2009: Reader jumpjack has created a Google Code project for this macro. You can download the latest source code on the project page.
_________________________________________

There are many good reasons to strip attachments from your email messages. The main reason for me is that I often embed email messages into my Outlook tasks for quick reference. Since some tasks have multiple emails (each with multiple attached files), I need a way to keep the task size manageable. So, I simply strip the attachments before embedding the email into the task. Another reason to strip attachments is to improve Outlook performance. Smaller PST files are less likely to be corrupted and are faster to search and index.

The Outlook VBA macro below is one easy way to strip attachments from your messages. Simply select one or more messages in the Outlook explorer window, then activate the macro. The result is shown in the screen shot below. As you can see, all of the attachments throughout the email are numbered and replaced with links at the top of the message. There is even a hyperlink to the folder containing the attachments. The macro also saves a text copy of the original email message along with the attachments for future reference.

You’ll notice that there is still one small attachment remaining called “Attachments Removed”. This is added so that the paperclip icon in Outlook is still active, which indicates that the message has (or had) attachments.

The attachments archive folder is organized with one folder per email, as shown below. The folders are named using the date of the message, the sender name, and the subject line. At the end of the year, you can grab the whole collection and zip it up for archive purposes. Since the links are hard coded into the emails, you’ll want to be consistent with your folder locations. That is why I simply use “C:\Outlook Attachments\” along with the year. If I ever want to restore some old messages and be able to browse the file attachments, I know exactly where to put them.


Ok, so here is an excerpt of the code. Download the full version (link to zip file below). Unzip and place the “Outlook Attachments” folder at your C:\ root. This will give you a copy of the 0 kb “Attachments Removed” file in the right location for the macro to use. Next, paste the code from the text file into any module in your Visual Basic Editor.


Public Sub StripAttachments_Explorer()
'This VBA Macro removes attachments from whatever emails are selected
'in the Outlook explorer window and stores them on the hard drive. Links
'to the stored files are added to the email. Note that RTF and PlainText
'messages are converted to HTML. The hooks are still below if you want to
'uncomment those line and handle text messages separately.
'Tested with Outlook 2003 only.
'v1.3, Carl C, 22-Feb-09
'http://manage-this.com
'
On Error GoTo ErrorHandler
'
'Edit this path to point to the root for your archive. This
'folder must already exist before for you start using this tool.
'Choose a root folder that is easy to remember for restoring
'message attachments later since the message bodies will be
'written with hard links to this location.
Const RootFolder = "C:\\Outlook Attachments\\2009\\"
'
'Threshold message size (in kilobytes) - Messages smaller than this get skipped.
Const THRESH As Long = 100 'kb
'
Dim olns As Outlook.NameSpace
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelectedItems As Outlook.Selection
Dim i, J, Counter As Integer
Dim msgFormat As Long
Dim Header, FileList, Footer As String
Dim attPath, attFileName, msgFolder, msgSender, msgSubject, yearFolder, temp As String
Dim oleFound, dropSubject As Boolean
'
Set olns = Application.GetNamespace("MAPI")
'
Set objSelectedItems = olns.Application.ActiveExplorer.Selection
'
'Make sure base path exists
If Dir(RootFolder, vbDirectory) = "" Then
MsgBox "Root Folder Not Found!" & vbCrLf & _
"Please create the following folder first: " & vbCrLf & RootFolder
GoTo ExitSub
End If
'
For Each objMsg In objSelectedItems
'
' Skip anything that's not a mail message (calendar items, tasks, etc.)
If objMsg.Class = olMail Then
'
Set objAttachments = objMsg.Attachments
Counter = objAttachments.Count
'
'Only execute if there is at least one attachment in the message
If Counter > 0 Then
'
'Check if the attachments have already been removed - if so, don't do it again
If objAttachments.Item(1).Type <> olOLE Then
If (objAttachments.Item(1).FileName = "Attachments Removed") _
And (Counter = 1) Then
GoTo TheNextMessage
End If
End If
'
'If the current message is fairly small, then skip it. It likely containts only
'tiny pics in the signature or a background image. No point in stripping those.
'Note - It would be better to check the size of each attachment, but there is no
'clean way to do this in Outlook 2003. Would require PR_ATTACH_SIZE (0x0E200003)
'property of the attachment... See http://www.cdolive.com/cdo10.htm
If (objMsg.Size < (1024 * THRESH)) Then
GoTo TheNextMessage
End If
'
'Check to see if any of the attachments are OLE format. If so, skip the
'entire message since stripping these is messy
oleFound = False
For i = objAttachments.Count To 1 Step -1
If objAttachments.Item(i).Type = olOLE Then
oleFound = True
Exit For
End If
Next i
If oleFound Then GoTo TheNextMessage
'
'Note - I disabled the year folder since it had to be checked for every
'message. Added it to the Root Path definition instead.
'
'Create the year folder if it doesn't already exist
'yearFolder = RootFolder & Strings.Format(objMsg.ReceivedTime, "yyyy") & "\\"
'If Dir(yearFolder, vbDirectory) = "" Then
' MkDir (yearFolder)
'End If
'
'Some of the dual-byte (DBCS) chars cause problems since the subject line is
'used in the file path name. If the message format does not belong to one of
'the formats below, then don't use the subject line in the path or file name.
dropSubject = False
msgFormat = objMsg.InternetCodepage
If ((msgFormat = 28592) Or (msgFormat = 1250) Or (msgFormat = 20127) _
Or (msgFormat = 28591) Or (msgFormat = 1252)) Then
msgSubject = objMsg.Subject
Else
msgSubject = "message"
dropSubject = True
End If
'
'Strip illegal chars from msgSubject
invalidChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|", "…")
For J = LBound(invalidChars) To UBound(invalidChars)
temp = Replace(msgSubject, invalidChars(J), " ")
msgSubject = temp
Next J
msgSubject = Replace(msgSubject, "RE ", "")
msgSubject = Replace(msgSubject, "FW ", "")
'
'
'CODE CONTINUES FOR MANY MORE LINES...
'CLICK LINK BELOW TO DOWNLOAD FULL VERSION...

DOWNLOAD THE CODE: Email Attachments Stripper v1.3
NOTE: Version 1.3 will remain hosted here, but the source is being moved to Google Code as of Oct 2009. The latest version will be available on the project page here.

Note that this has only been tested with Outlook 2003 and Windows XP. If you have a different system configuration, it may require some tweaks. Thanks especially to Sue Mosher and her outstanding web site, OutlookCode.com. Many examples scattered throughout her site were used to create this tool.

To make this tool easier to use, I would also recommend adding a shortcut button to one of your Outlook menu bars. I like to use the little disk icon with the down arrow (shown below).

Yes, there are some other super-secret icons on that menu bar that will be revealed in future posts. In the mean time, have fun stripping!

-Carl