' by Nicola Delfino' 30-03-2005: First version' 26-11-2006: Updated for Outlook 2007' 28-11-2006: Updated with notes from rgreg' 09-06-2009: Saves the file(s) to a folder location (thanks to John Harvey and Patrick Philippot)' Memory problem with many attach to remove (FIXED) (thanks to John Harvey and Patrick Philippot)' 22-10-2009: Now it uses default "My document folder"' added HTML and link to saved files (thanks to Steve Evans)'' 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''Private Declare Function SHGetFolderPath Lib "shell32.dll" Alias "SHGetFolderPathA" ( _ByVal HWnd As Long, ByVal csidl As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As LongPrivate Const MAX_PATH = 260&Public Sub StripAttachments()Dim ilocation As StringDim objOL As Outlook.ApplicationDim objMsg As ObjectDim objAttachments As Outlook.AttachmentsDim objSelection As Outlook.SelectionDim i As LongDim lngCount As LongDim strFile As StringDim strFolder As StringDim result'Put in the folder location you want to save attachments toilocation = GetSpecialFolder(&H5) & "\Removed Attachs\" ' CSIDL_MY_DOCUMENTS As Long = &H5"On Error Resume Nextresult = MsgBox("Do you want to remove attachments from selected email(s)?", vbYesNo + vbQuestion)If result = vbNo ThenExit SubEnd 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.AttachmentslngCount = objAttachments.CountIf 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.Dim strHTML As StringstrHTML = "<li><a href=" & Chr(34) & "file:" & ilocation & objAttachments.Item(i).FileName & Chr(34) & ">" & objAttachments.Item(i).FileName & "</a><br>" & vbCrLfstrFile = strFile & strHTML' Save the attachment as a file.objAttachments.Item(i).SaveAsFile (ilocation & objAttachments.Item(i))' Save the attachment as a file.objAttachments.Item(i).DeleteNext istrFile = "Attachment removed from the message and backup-ed to[<a href='" & ilocation & "'>" & ilocation & "</a>]:<br><ul>" & strFile & "</ul><hr><br><br>" & vbCrLf & vbCrLfDim objDoc As ObjectDim objInsp As Outlook.InspectorSet objInsp = objMsg.GetInspectorSet objDoc = objInsp.WordEditorobjDoc.Characters(1).InsertBefore strFileobjMsg.HTMLBody = strFile + objMsg.HTMLBodySet objInsp = NothingSet objDoc = NothingEnd IfstrFile = strFile & vbCrLf & vbCrLfobjMsg.SaveEnd IfNextExitSub:Set objAttachments = NothingSet objMsg = NothingSet objSelection = NothingSet objOL = NothingEnd SubPublic Function GetSpecialFolder(FolderCSIDL As Long) As StringDim HWnd As LongDim Path As StringDim Res As LongDim ErrNumber As LongDim ErrText As StringPath = String$(MAX_PATH, vbNullChar)''''''''''''''''''''''''''''''''''''''''''''' get the folder name''''''''''''''''''''''''''''''''''''''''''''Res = SHGetFolderPath(HWnd:=0&, _csidl:=FolderCSIDL, _hToken:=0&, _dwFlags:=0&, _pszPath:=Path)Select Case ResCase S_OKPath = TrimToNull(Text:=Path)GetSpecialFolder = PathCase S_FALSEMsgBox "The folder code is valid but the folder does not exist."GetSpecialFolder = vbNullStringCase E_INVALIDARGMsgBox "The value of FolderCSIDL is not valid."GetSpecialFolder = vbNullStringCase ElseErrNumber = Err.LastDllErrorErrText = "ERROR!"MsgBox "An error occurred." & vbCrLf & _"System Error: " & CStr(ErrNumber) & vbCrLf & _"Description: " & ErrTextEnd SelectEnd FunctionPublic Function TrimToNull(Text As String) As StringDim N As LongN = InStr(1, Text, vbNullChar)If N ThenTrimToNull = Left(Text, N - 1)ElseTrimToNull = TextEnd IfEnd Function
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.
TIP: You can select more message at once too. This is useful if you want to clear a big number of messages you already have archived.
Hope this helps!
Note: I already developed this VBA for outlook 2003, but Outlook 2007 requires some small update. following code should work.
UPDATE (09/06/09): Thanks to John Harvey and Patrick Philippot now the procedure save attachments in a specific folder and make good use of outlook memory:-)
UPDATE (22/10/09): Thanks to Steve Evans now it shows a link to folder where the attaches are saved