Back in 2007 I created a post on an Outlook Macro to save all attachments for an e-mail. Some people were having a problem downloading the file (not sure why as it worked for me) but to help out thought I’d repost the code in full.
Note I have not tried this with Outlook 2010, so use at your own risk.
Option Explicit
Public Sub SaveAttachments()
'Note, this assumes you are in the a folder with e-mail messages when you run it.
'It does not have to be the inbox, simply any folder with e-mail messages
Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Selection
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim outputDir As String
Dim outputFile As String
Dim fileExists As Boolean
Dim cnt As Integer
'Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL)
Dim fso As FileSystemObject
Set Exp = App.ActiveExplorer
Set Sel = Exp.Selection
Set fso = New FileSystemObject
outputDir = GetOutputDirectory()
If outputDir = "" Then
MsgBox "You must pick an directory to save your files to. Exiting SaveAttachments.", vbCritical, "SaveAttachments"
Exit Sub
End If
'Loop thru each selected item in the inbox
For cnt = 1 To Sel.Count
'If the e-mail has attachments...
If Sel.Item(cnt).Attachments.Count > 0 Then
MsgTotal = MsgTotal + 1
'For each attachment on the message...
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
'Get the attachment
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
outputFile = att.fileName
fileExists = fso.fileExists(outputDir + outputFile)
Do While fileExists = True
outputFile = InputBox("The file " + outputFile _
+ " already exists in the destination directory of " _
+ outputDir + ". Please enter a new name, or hit cancel to skip this one file.", "File Exists", outputFile)
'If user hit cancel
If outputFile = "" Then
'Exit leaving fileexists true. That will be a flag not to write the file
Exit Do
End If
fileExists = fso.fileExists(outputDir + outputFile)
Loop
'Save it to disk if the file does not exist
If fileExists = False Then
att.SaveAsFile (outputDir + outputFile)
AttTotal = AttTotal + 1
End If
Next
End If
Next
'Clean up
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing
Set fso = Nothing
'Let user know we are done
Dim doneMsg As String
doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
MsgBox doneMsg, vbOKOnly, "Save Attachments"
Exit Sub
ErrorHandler:
Dim errMsg As String
errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
Dim errResult As VbMsgBoxResult
errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
Select Case errResult
Case vbAbort
Exit Sub
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
End Sub
'Found this code in a google groups thread here:
'http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
'or http://shrinkster.com/l0v
Public Function GetOutputDirectory() As String
Dim retval As String 'Return Value
Dim sMsg As String
Dim cBits As Integer
Dim xRoot As Integer
Dim oShell As Object
Set oShell = CreateObject("shell.application")
sMsg = "Select a Folder To Output The Attachments To"
cBits = 1
xRoot = 17
On Error Resume Next
Dim oBFF
Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
If Err Then
Err.Clear
GetOutputDirectory = ""
Exit Function
End If
On Error GoTo 0
If Not IsObject(oBFF) Then
GetOutputDirectory = ""
Exit Function
End If
If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = "folder") Then
retval = ""
Else
retval = oBFF.self.Path
'Make sure there's a \ on the end
If Right(retval, 1) <> "\" Then
retval = retval + "\"
End If
End If
GetOutputDirectory = retval
End Function
March 22, 2012 at 4:42 am
This is very useful – how would you change the macro to remove the attachments from the emails after you’ve saved them? (I don’t want to delete the emails from my inbox, just move the egregious attachments elsewhere)
April 19, 2012 at 7:44 am
Thank you so much for this code.
I modified it for my needs around mailbox quota.
I didn’t want to browse for the folder each time, so I set it up to save to a path of “SenderName\Subject\DateTime” under a root directory provided in the script. This required a little bit of work because file paths don’t like colons, slashes, or quotes in the path name, but these aren’t a problem for subject names and colons are always found in datetime fields.
I wanted to remove the attachments, and I wanted to maintain a link between the file and the email.
I also wanted to ensure that the emails continued to show up in my search results when I typed “hasattachments:yes” because this is just how I think, so I added a tiny attachment back in. To do this, I have to maintain a file on disk somewhere that I attach to each email.
The code is pasted below because I find it so useful and because I so appreciate the massive kickstart you gave me through your code.
Public Sub SaveAttachments()
‘Note, this assumes you are in the a folder with e-mail messages when you run it.
‘It does not have to be the inbox, simply any folder with e-mail messages
Dim App As New Outlook.Application
Dim Exp As Outlook.Explorer
Dim Sel As Outlook.Selection
Dim AttachmentCnt As Integer
Dim AttTotal As Integer
Dim MsgTotal As Integer
Dim EmptyAttachment As String
Dim RootDirectory As String
Dim outputDir As String
Dim outputFile As String
Dim fileExists As Boolean
Dim cnt As Integer
‘Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL)
Dim fso As FileSystemObject
‘**************************************************************************************************
‘******** DEFAULTS *****************************************************************************
‘**************************************************************************************************
RootDirectory = “C:\Users\username\Documents\Mail Attachments”
‘Note that the EmptyAttachment file needs to exist. Just create a new text file and save it empty.
EmptyAttachment = “C:\Temp\Empty Attachment.txt”
‘**************************************************************************************************
‘**************************************************************************************************
Set Exp = App.ActiveExplorer
Set Sel = Exp.Selection
Set fso = New FileSystemObject
‘Loop thru each selected item in the inbox
For cnt = 1 To Sel.Count
‘If the e-mail has attachments…
If Sel.Item(cnt).Attachments.Count > 0 Then
outputDir = GetOutputDirectory(RootDirectory, Sel.Item(cnt))
MsgTotal = MsgTotal + 1
‘For each attachment on the message…
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
‘Get the attachment
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
outputFile = att.FileName
fileExists = fso.fileExists(outputDir + outputFile)
Do While fileExists = True
outputFile = InputBox(“The file ” + outputFile _
+ ” already exists in the destination directory of ” _
+ outputDir + “. Please enter a new name, or hit cancel to skip this one file.”, “File Exists”, outputFile)
‘If user hit cancel
If outputFile = “” Then
‘Exit leaving fileexists true. That will be a flag not to write the file
Exit Do
End If
fileExists = fso.fileExists(outputDir + outputFile)
Loop
‘Save it to disk if the file does not exist
If fileExists = False Then
att.SaveAsFile (outputDir + outputFile)
If Sel.Item(cnt).BodyFormat = olFormatHTML Or Sel.Item(cnt).BodyFormat = olFormatRichText Then
Dim BodyStart As Integer
‘The following lines are for debugging, to allow inspection of the raw content of an HTML or Rich Text email
‘Content Before:
‘ Dim FileObject As File
‘ Dim Stream As TextStream
‘ Set Stream = fso.CreateTextFile(“c:\temp\test.txt”, True)
‘ Stream.Write (Sel.Item(cnt).HTMLBody)
‘Make the change to the body
BodyStart = InStr(1, Sel.Item(cnt).HTMLBody, “”, “>Attachment Saved to ” + outputFile +
““, BodyStart + 1, 1, vbTextCompare)
‘Content After
‘ Stream.Write (Sel.Item(cnt).HTMLBody)
‘ Stream.Close
‘ Sel.Item(cnt).Save
End If
If Sel.Item(cnt).BodyFormat = olFormatPlain Then
Sel.Item(cnt).Body = “Attachment Saved to “”file:///” + outputDir + outputFile + “””” + vbCrLf + Sel.Item(cnt).Body
End If
AttTotal = AttTotal + 1
End If
Next ‘ Attachment
‘Remove all attachments
While Sel.Item(cnt).Attachments.Count > 0
Set att = Sel.Item(cnt).Attachments(1)
att.Delete
Wend
If Sel.Item(cnt).Class = olMail Then
Dim oItem As MailItem
Set oItem = Sel.Item(cnt)
oItem.Attachments.Add (EmptyAttachment)
End If
End If ‘ There are attachments
Next ‘ Selected Item
‘Clean up
Set Sel = Nothing
Set Exp = Nothing
Set App = Nothing
Set fso = Nothing
Set att = Nothing
Set oItem = Nothing
‘Let user know we are done
‘ Dim doneMsg As String
‘ doneMsg = “Completed saving ” + Format$(AttTotal, “#,0″) + ” attachments in ” + Format$(MsgTotal, “#,0″) + ” Messages.”
‘ MsgBox doneMsg, vbOKOnly, “Save Attachments”
Exit Sub
ErrorHandler:
Dim errMsg As String
errMsg = “An error has occurred. Error ” + Err.Number + ” ” + Err.Description
Dim errResult As VbMsgBoxResult
errResult = MsgBox(errMsg, vbAbortRetryIgnore, “Error in Save Attachments”)
Select Case errResult
Case vbAbort
Exit Sub
Case vbRetry
Resume
Case vbIgnore
Resume Next
End Select
End Sub
‘Found this code in a google groups thread here:
‘http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
‘or http://shrinkster.com/l0v
Public Function GetOutputDirectory(RootDirectory As String, oItem As MailItem) As String
‘Code to prompt user to browse for folder has been commented out.
‘In exchange, the mail object is parsed, and the folder is created from SenderName/Subject/DateTime
‘ Dim retval As String ‘Return Value
‘ Dim sMsg As String
‘ Dim cBits As Integer
‘ Dim xRoot As Integer
‘ Dim oShell As Object
‘ Set oShell = CreateObject(“shell.application”)
‘ sMsg = “Select a Folder To Output The Attachments To”
‘ cBits = 1
‘ xRoot = 17
‘ On Error Resume Next
‘ Dim oBFF
‘ Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
‘ If Err Then
‘ Err.Clear
‘ GetOutputDirectory = “”
‘ Exit Function
‘ End If
‘ On Error GoTo 0
‘ If Not IsObject(oBFF) Then
‘ GetOutputDirectory = “”
‘ Exit Function
‘ End If
‘ If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = “folder”) Then
‘ retval = “”
‘ Else
‘ retval = oBFF.self.Path
‘Make sure there’s a \ on the end
‘ If Right(retval, 1) “\” Then
‘ retval = retval + “\”
‘ End If
‘ End If
Dim oFSO As FileSystemObject
Dim FolderName As String
Set oFSO = New FileSystemObject
FolderName = RootDirectory
If Not oFSO.FolderExists(FolderName) Then
oFSO.CreateFolder (FolderName)
End If
FolderName = FolderName + “\” + oItem.SenderName
If Not oFSO.FolderExists(FolderName) Then
oFSO.CreateFolder (FolderName)
End If
‘Certain characters that are just fine in subject lines are problematic for filesystem folder names
‘Remove them
‘(I know there’s a better way to do this, but I’ll leave that for someone else to enhance)
Dim Subject
Subject = Replace(oItem.Subject, “RE:”, “”, 1, -1, vbTextCompare)
Subject = Replace(Subject, “FW:”, “”, 1, -1, vbTextCompare)
Subject = Replace(Subject, “.”, “”, 1, -1, vbTextCompare)
Subject = Replace(Subject, “”””, “”, 1, -1, vbTextCompare)
Subject = Replace(Subject, “:”, “”, 1, -1, vbTextCompare)
Subject = Replace(Subject, “/”, “”, 1, -1, vbTextCompare)
Subject = LTrim(RTrim(Subject))
FolderName = FolderName + “\” + Subject
If Not oFSO.FolderExists(FolderName) Then
oFSO.CreateFolder (FolderName)
End If
‘Remove colons and slashes in DateTime
FolderName = FolderName + “\” + Replace(Replace(oItem.ReceivedTime, “/”, “-“, 1, -1, vbTextCompare), “:”, “.”, 1, -1, vbTextCompare)
If Not oFSO.FolderExists(FolderName) Then
oFSO.CreateFolder (FolderName)
End If
GetOutputDirectory = FolderName + “\”
End Function
May 21, 2012 at 4:48 pm
[…] UPDATE: Some users were having problems downloading the code, so I’ve posted it at: https://arcanecode.com/2011/07/16/revisting-the-outlook-save-all-attachments-macro/ […]
July 9, 2012 at 11:57 am
This was incredibly helpful, thank you! Once I updated my reference to the scrrun.dll, it worked flawlessly for me.
July 12, 2012 at 8:09 am
[…] all props and credit to ArcaneCode, I post here a fork of his save-attachments macro. My needs were a bit different from […]
August 16, 2012 at 7:25 am
Thanks for the macro. I got tired of making my own name changes when there was a similarly named file already in the destination directory so I made a slight modification to the script that would automatically add a number to the end of the file name. This number will increment on each iteration of the loop as well.
Here is the relevant part of the macro that I changed:
‘For each attachment on the message…
For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
‘Get the attachment
Dim att As Attachment
Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
outputFile = att.FileName
fileExists = fso.fileExists(outputDir + outputFile)
Do While fileExists = True
cntx = cntx + 1
outputFile = outputFile + Str(cntx)
‘outputFile = InputBox(“The file ” + outputFile _
+ ” already exists in the destination directory of ” _
+ outputDir + “. Please enter a new name, or hit cancel to skip this one file.”, “File Exists”, outputFile)
‘If user hit cancel
If outputFile = “” Then
‘Exit leaving fileexists true. That will be a flag not to write the file
Exit Do
End If
fileExists = fso.fileExists(outputDir + outputFile)
Loop
Thanks for this. It is a BIG help.