Save all attachments from selected folder
May 1, 2009 @ 7:00 AM by JP • 1 views • No Comments »
If you ever needed to save all the attachments from a selected mail folder to a folder on your hard drive, here's one technique.
This sample VBA code will go through the default Inbox folder and save all the attachments from each message to a folder you specify. If you make the second argument True, it will also strip the attachments (i.e. delete them from the emails).
Your PST file might be slow, or your network administrator might tell you that you are using up too much space, usually in the form of an auto-email stating "your mailbox has reached it's size limit." This code will solve that by shrinking your network footprint.
This code will only run on the default Inbox, but below I'll show you a technique that you can use to adapt this code to run on any folder.
ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
' by Jimmy Pena, http://www.codeforexcelandoutlook.com 4/28/2009
' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
On Error Resume Next
MkDir folderName
If Err <> 0 Then Exit Sub
On Error GoTo 0
End If
' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
folderName = folderName & "\"
End If
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = GetDefaultFolder(olFolderInbox)
Set itms = olFldr.Items
' create subset of items collection
Dim newItems As Outlook.Items
Set newItems = itms.Restrict("[Attachment] > 0")
' if there are no messages with attachments, exit
If newItems.Count = 0 Then
RmDir folderName
Exit Sub
End If
' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
Set MsgAttach = Msg.attachments
For attachmentNumber = MsgAttach.Count To 1 Step -1
MsgAttach.item(attachmentNumber).SaveAsFile _
folderName & MsgAttach.item(attachmentNumber).FileName
' delete attachment (optional)
If StripAttachments Then
MsgAttach.item(attachmentNumber).Delete
End If
Next attachmentNumber
Next Msg
End Sub
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
End Function
Function FolderExists(ByVal strPath As String) As Boolean
' from http://allenbrowne.com
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
Usage:
Call SaveAllAttachments("C:\files\", False)
End Sub
GetDefaultFolder is a slightly modified version of the code I posted in Get Default Folder Items Collection. I actually wrote the above code first, before writing the version that appears in that post.
If you want to use GetDefaultFolderItems instead of GetDefaultFolder, just change
Set olFldr = GetDefaultFolder(olFolderInbox)
Set itms = olFldr.Items
to
Set itms = GetDefaultFolderItems(olFolderInbox)
Use any Outlook folder
If you want a folder other than the default Inbox, there are two ways to do it.
- Allow end user to pick folder
- Walk the folder hierarchy and hard code the folder
To pick the folder you want to scrub each time you run the code, change
Set olFldr = GetDefaultFolder(olFolderInbox)
to
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
This will open the Select Folder dialog box with a tree view of your Outlook folders. Once you choose the folder you want, a MAPIFolder Object with a reference to the chosen folder is returned to the code. Since olFldr is declared as a MAPIFolder object, it fits perfectly. You'll need to add the "Is Nothing" check to make sure the user didn't click Cancel.
You can also walk the folder hierarchy, if, for example, you always use the same folder to store emails with attachments.
In that case, change
Set olFldr = GetDefaultFolder(olFolderInbox)
to
Set olFldr = Outlook.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderInbox).Folders("Sub Folder 1")
where "Inbox\Sub Folder 1" is the folder where the emails are kept. Keep adding ".Folders("")" to walk down the tree; A subfolder "\Inbox\My Messages\My Emails\Emails With Attachments" would be reached like this:
Set olFldr = Outlook.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderInbox).Folders("My Messages").Folders("My Emails").Folders("Emails With Attachments")
Use any hard drive folder
Instead of specifying the folder as an argument to this procedure, we can modify the code in a few ways.
- Allow end user to pick folder
- Hard code the folder
In either case, remove the folderName argument from the function call. You would declare folderName inside the sub.
To let the user choose the folder, I'll borrow the SelectFolder Function from Save Incoming Attachments, Choose Your Folder. That function will display a dialog box that lets the user select (or create) a hard drive folder. Then you would call it like this:
folderName = SelectFolder()
If you always plan on using the same folder, just hard code it like this:
folderName = "C:\My Files\"
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA (or subscribe via email). Keep Reading »
Previous Post: Get Default Folder Items Collection
Next Post: Excel Tutorial Series – VBA Macros, Part Two Of Two
Very interested by this proc., I would like know if you see how to adapt it to sytematically print the attachment when the mail is classified in a specific file with an OL rule ?
Thanks by advance
Philippe
Printing attachments is tough, how do you know which method to use? There are native print methods for Excel spreadsheets and Word documents, and you can script a print routine for PDFs as well, but they require invocation of each attachment's object model (with requisite overhead). I think I saw a script somewhere that would generically print out any filetype, I'll try to find it.
This is brilliant, exactly what I've been looking for – thanks a million!! If it's not too much to ask… would you tell me in laymans terms what changes to make to this code so that it will append something unique to the file name so that files with the same name are not overwritten? Adding the date that the email was received would be most efficient for my needs.
Thanks again JP,
-Dylan
Two ways:
1) Right after
For attachmentNumber = MsgAttach.Count To 1 Step -1
you'd need to check the folder for an existing file with the same name. If the filename exists, start a Do Loop and add an incrementing number after the filename. Keep using the Dir function to check the newly created filename. Once Dir returns "", you have your filename.
2) Right after
For attachmentNumber = MsgAttach.Count To 1 Step -1
parse the filename and insert Msg.ReceivedTime before the file extension.
Fantastic routine.
Would you mind giving sample code for the changes in Filename as per the last question?
I just cannot get it to work.
Thanks,
martin.
Will do, I'll make a separate post out of it.
Very nice! Is it possible to insert a link to the removed attachment in the email?
Thanks again for a brilliant piece of code.
Chris
Yes, see Send links via Outlook email for a way to update the MailItem.HTMLBody property with a link to a file.
Thank you for the code. This is great. Just what I was looking for.
I have something similar to your code that saves the email as a text as well as any attahcments to a local drive. What happens is it goes through the iteration of attachemnts and then gives the following message:
"-2116009979 Cannot save the attachment. Can't create file: image001.jpg. Right-click the folder you want to create the file in, and then click the Properties on the shortcut menu to check your permissions for the folder"
I have found this error message to occur with different error numbers so I don't know how to trap it with error handling. So i could at least get the name of the email and the attachment to write to a table so it can be done manually while the code can still save all the rest and still run through the folder to completion.
Any way this error can be trapped?
Does it happen on the first iteration, or somewhere after that? If the latter, the file might be a duplicate. Try stepping through the code and when it errors, check the value of each variable. And of course I would check to make sure the folder is writable.
Thank you for the quick response. I have a counter that is going through each email and I am using that counter as part of the save filename. Same thing for the attachments. So I don't think it's a dup issue.
I use the pickfolder to allow the user to select which folder to process. Some folders it runs with no problems at all and all emails and attachments are saved accurately, but those emails with that problem attachment then it halts the code.
I thought if I could at least trap the error, write the email name / attachment names to a table, then I could still have the code continue to do all the other emails/attachments in the folder while still capturing the problem child so it can be done manually at the least.
Is that even feasible?
If you're getting different errors each time, try doing a search on the text of the error message.
Or rethink your process: Are the JPEG images the only thing preventing the code from completing successfully? If so, do you really need to preserve them?
With a filename like that, it sounds like a signature file image or hidden Outlook image (i.e. useless) anyway.