I receive often emails with big attachment that fill my inbox space very quickly.
On the other side, I usually like both to remove these attach and keep the email to preserve the thread for future use. Outlook 2007 don't have this feature so I wrote the following VBA function I added to a button on my client that resolve easily this task.
' by Nicola Delfino
' 30-03-2005: First version
' 26-11-2006: Updated for Outlook 2007
' 28-11-2006: Updated with notes from rgreg
' Modified by John Harvey and Patrick Philippot
' 09-06-2009: Saves the file(s) to a folder location
' Memory problem with many attach to remove (FIXED)
'
'
' based on code found at on http://www.outlookcode.com/
'
' Setup and instructions
' (1) Digitally sign VBA project
' start->office->Microsoft office tools->digital certificates for VBA
' create a certificate
' (2) sign the code
' from Outlook -> menu -> Tools -> Macros -> Visual Basic Editor (VBA)
' project 1 -> Microsoft Office Outlook -> ThisOutlookSession (double ckick)
' * paste this source code *
' from Microsoft Visual Basic -> menu -> Tools -> digital signature -> (choose certificate previously created)
' (3) add icon on toolbar
' from outlook
' tools->customize (select "Commands" TAB)
' add icon on toolbar
' [rearrange commands] to change icon and name on toolbar
' (4) be sure that tools->macros->security
' on "thrusted publishers" "trust all installed add-ins and templates" is checked
'
'
Public Sub StripAttachments()
Dim ilocation As String
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 result
'Put in the folder location you want to save attachments to
ilocation = "D:\nicold-MyDocuments\Removed Attachs\"
On Error Resume Next
result = MsgBox("Do you want to remove attachments from selected email(s)?", vbYesNo + vbQuestion)
If result = vbNo Then
Exit Sub
End If
' Instantiate an Outlook Application object.
' Set objOL = CreateObject("Outlook.Application")
Set objOL = 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 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.
strFile = ""
For i = lngCount To 1 Step -1
' Save attachment before deleting from item.
' Get the file name.
strFile = strFile & objAttachments.Item(i).FileName & " - " & vbCrLf
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile (ilocation & objAttachments.Item(i))
' Save the attachment as a file.
' objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
Next i
strFile = "Attachment moved to: " & ilocation & strFile & vbCrLf & vbCrLf
Dim objDoc As Object
Dim objInsp As Outlook.Inspector
Set objInsp = objMsg.GetInspector
Set objDoc = objInsp.WordEditor
objDoc.Characters(1).InsertBefore strFile
' objDoc.Save
objMsg.HTMLBody = strFile + objMsg.HTMLBody
Set objInsp = Nothing
Set objDoc = Nothing
End If
strFile = strFile & vbCrLf & vbCrLf
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
