Detaching and referencing attachments in Outlook

After having moved back to Outlook and a 200mb mail quota from a 25 Mb Google Mail account I revisited my earlier attempts to automate detaching email attachments from mail items to reduce the overall size of the mailbox. Even with Autoarchiving setup to run every 14 days I get frequent ‘Mailbox is full’ error messages, and moving items less than 2 weeks old into archive makes it a pain following up or searching for required items.

The steps below allow you to save attachments from Selected messages to a predefined folder and updates the messages with references to these attachments (links/shortcuts). The size per attachment in the email reduces to 4K each making mailbox management a lot easier and less frequent.

NOTE: the code was put together from snippets found at Outlookcode.com and customized. Was too excited to note down the specific authors, sorry for that.

1. Before you begin

if you’re using Office 2007, you need to get the Collaborative Data Objects from the microsoft download website. For Office 2003 and older versions, this library is bundled with the Office Suite.

Download details- Collaboration Data Objects, version 1.2.1

2. Enabling signed Macros in Outlook

Run “SELFCERT.EXE” (found at the following path: c:\program files\microsoft office\office12\SELFCERT.EXE – replace the highlighted text with your office version).

Enter any text as the Certificate NamIe and click ok.

3. Download the Macro

Download the macro file here or copy paste from below (at the end of the post).

you might need to modify the Const Rootfolder to point to a directory of your choice (for me its My Documents\PnG\Mail attachments)

4. add the Macro to Outlook

Press Alt+F11 to access the VBA Editor. Copy paste the code into the editor, or Import the downloaded file into the editor. (see the video)

Go to the Tools->Digital Signature and Choose the digital certificate created in Step 2, using SelfCert.

You also need to reference the CDO and Microsoft Scripting library in your project before you’ll be able to run the MACRO.

5. Add the Macro to the Toolbar

For easier accessibility add the macro command to your toolbar. Go to “Right Click” on any toolbar and select “Customize“. From the left pane scroll down to Macros and select the StripAttachments from the pane on the right. Drag it to a toolbar to add it there.

6. Test the Macro

Select an email with an attachment and run the Macro. You can see the attachment size changes to 4K and browse to your selected destination folder, the file will be under a subfolder with the sender’s email address. (some emails are still getting dumped to Root folder, I assume thats because of the address being picked up from the Autocomplete cache, so I have changed it to SenderName instead of SenderEmail in my local copy.)

Double clicking the link the email opens up the original file.

Video

__________________________________________________

UPDATE: for windows 7 replace all references to ‘Scripting’ (Windows Scripting library) to ‘IWshRunTimeLibrary’

Code

Public Sub StripAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolder As String
Dim strAddress As String

On Error Resume Next

‘ Instantiate an Outlook Application object.
Set objOL = CreateObject(“Outlook.Application”)
‘ Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection

‘ Check each selected item for attachments.
‘ If attachments exist, save them to the Temp
‘ folder and strip them from the item.
For Each objMsg In objSelection
‘ This code only strips attachments from mail items.
If objMsg.Class = olMail Then
‘ Get the Temp folder.
strFolder = GetFolderForSender(objMsg)
If strFolder = “” Then
MsgBox “Could not get Mail Attachments folder”, vbOKOnly
GoTo ExitSub
End If

‘ Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
‘ We need to use a count down loop for
‘ removing items from a collection. Otherwise,
‘ the loop counter gets confused and only every
‘ other item is removed.
For i = lngCount To 1 Step -1
‘ Save attachment before deleting from item.
‘ Get the file name.
strFile = objAttachments.Item(i).FileName
‘ Combine with the path to the Temp folder.
strFile = strFolder & strFile
‘ Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
‘ Delete the attachment.
objAttachments.Item(i).Delete
objMsg.Attachments.Add strFile, _
OlAttachmentType.olByReference
objMsg.Save
Next i
End If
objMsg.Save
End If
Next

ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

Private Function GetFolderForSender(objMsg As Outlook.MailItem) As String
Const TemporaryFolder = 2
‘Root folder for saving Mail attachments. For each item a subfolder with the email sender’s name will be created.
Const RootFolder = “C:\Documents and Settings\bb5478\My Documents\Png\Mail Attachments\”

‘Requires a project reference to “Scrrun.dll” (Windows Scripting)
Dim fso As Scripting.FileSystemObject
Dim tFolder As Scripting.Folder

On Error Resume Next

‘ Instantiate a WSH (Windows Scripting Host)
‘ FileSystemObject.
Set fso = CreateObject(“Scripting.FileSystemObject”)
‘ Get the Temp folder.
‘Nabeel – Start Edit
Set tFolder = fso.GetFolder(RootFolder)
‘Set tFolder = fso.GetSpecialFolder(TemporaryFolder)
‘Nabeel – End Edit

If Err Then
‘Nabeel – Start Edit
Set tFolder = fso.CreateFolder(RootFolder)
‘GetFolderForSender = “”
‘else
End If
‘Nabeel – End Edit
GetFolderForSender = LCase(tFolder.Path)
‘ Add “\” to the rightmost part of the path to
‘ the Temp folder if necessary.
If Right$(GetFolderForSender, 1) <> “\” Then
GetFolderForSender = GetFolderForSender & “\”
End If
Set tFolder = fso.GetFolder(GetFolderForSender & objMsg.SenderEmailAddress) ‘replace with objMsg.SenderName if you want subfolder to be named with the sender name instead of email address
If Err Then
Set tFolder = fso.CreateFolder(GetFolderForSender & objMsg.SenderEmailAddress) ‘ replace same as above.
End If
‘End If
GetFolderForSender = LCase(tFolder.Path)
‘ Add “\” to the rightmost part of the path to
‘ the Temp folder if necessary.
If Right$(GetFolderForSender, 1) <> “\” Then
GetFolderForSender = GetFolderForSender & “\”
End If

Set fso = Nothing
Set tFolder = Nothing
End_of_Function:
End Function