Save all attachments from selected folder
May 1, 2009 • JP • 30 Comments • Rate This Article
• Links to this article
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\"
(3 votes, average: 5.00 out of 5)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
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. 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.
Hello,
You're code has been very helpful. I would like to ask for a modification.
I would like to move the email along with the attachment to a different Outlook folder.
Can u provide some help with this task.
Thanks.
V
I'm not clear on what you need.
In these code samples, the attachment is being saved to a hard drive folder, not an Outlook folder, and (optionally) their relationship is being severed when the attachment is removed from the message.
Do you want to move both the email and the attachments to another Outlook folder? If so, do you want the attachments to remain with the email?
What criteria do you use to determine where the email goes?
Details please.
Here's that I'd like to do with the Outlook macro:
1. Read an email from a specified folder (for example: Inbox).
2. If the email has an attachment that I'm seeking (an Excel file for example), I'd like to place the attachment into a folder on the hard drive.
3. Then I'd like to modify the body of the text to indicate where the attachment resides.
4. Remove the attachment from the email.
5. Move the email (without the attachment) into an Outlook public folder.
I don't know how to do step 5. The rest of the steps I have successfully implemented in my macro.
Thanks for helping me. That was very kind of you to reply to my question.
Vinita
See http://www.outlookcode.com/d/code/getfolder.htm for assistance in getting a reference to a public folder. Then just use MailItem.Move to move the message to the folder.
Hi JP
This is just what I am looking for but..
I Have a Outlook 2007 DK
I get an error on this script it says: it can not read properties Attachment ?
is there problems between the danish code and english code?
any help would be appreciated..
Regards TFI
It's possible, since Outlook 2007 does allow you to restrict the items collection by attachment. So you might try the Danish word instead.
Your code example is greatly appreciated!! I am having one problem with it though and wanted to see if you had any thoughts. Running it from a command button within an Access 2007 front-end, and it cycles through correctly until it gets to :
For Each Msg in newitems
Where it presents a Run-time error '13': Type mismatch.
Any thoughts on why??
Do you have emails in your Inbox?
Yes, and they are actually in a Public folder that I allow to be chosen by the end-user (using the code as you described), and that all works, and in stepping through the code it appears to be working correctly because it does count the number of messages in the folder as selected, just fails immediately following that as it begins to loop through??
I very much appreciate your question and fast response!!
Z
Can you post the section of code that declares and creates the newitems variable?
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
folderName = "C:\XMLDemo\PriceAck\"
' 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 = Outlook.GetNamespace("MAPI").PickFolder '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
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
This is essentially identical to the example you posted above – although I inserted the code you cited to allow the end-user to select the folder from Outlook to strip, and plan on inserting code to allow them to choose the destination folder as well.
Many thanks!!
Z
I tested your code and it works, with one minor alteration: declare and pass folderName to the SaveAllAttachments procedure. You don't re-assign folderName inside the function as you have done by putting this line inside the procedure:
folderName = "C:\XMLDemo\PriceAck\"
Take it out and pass it to the function instead. Per my sample code, it would be:
Dim foldername As String
foldername = "C:\XMLDemo\PriceAck\"
Call SaveAllAttachments(foldername, True)
End Sub
JP,
I must be missing something still. I am still getting the run-time error 13 – type mismatch on the same line as before.
Here is the code as I have it.
Option Explicit
Public Function SaveAllAttachments(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
Dim folderName As String
folderName = "C:\XMLDemo\PriceAck\"
' 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 Function
On Error GoTo 0
End If
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder '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 Function
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 Function
Please use the VBA tags when posting code. You need these exact tags:
[cc lang='vb']
your code here
[/cc]
At this point I'm out of suggestions. You need to carefully step through the code and examine the value of each variable. Make sure NewItems points to something. Make sure there are emails in the target folder. Hover over each variable to make sure it has the value you expect. The Locals Window would be very useful here.
Or perhaps your sys admin has set up a policy preventing programmatic access.
This code has certainly saved me a lot of trouble, I thank you for it.
however there are a couple of things that I would like to do.
1) move all the emails (attachments and all) from the inbox to another outlook subfolder in the inbox (after the
attachment has been saved) to a folder called Extracted. (so they are not saved again)
2) Select the emails the attachments are saved from (ie all emails with the subject 'figures'.)
hope you can help.
Thanks
Alan
Hi! I really like this! Is it possible (and if so, how) to modify this to work with other email programs, like Eudora and Incredimail? And if so, where do you place the code once it's completed?
No idea. Even if it was possible, the code would have to reside in a program that supports VBA, which (to my knowledge) neither of those mail programs do. If that's the case, you could even put the code in Excel or Access.