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. Also note that it will only work as written when there are only emails in the Inbox. If the Inbox contains other items, the code needs to be amended.
Sub SaveAllAttachments(ByVal folderName As String, _
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.jpsoftwaretech.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:
Sub test()
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\"
About JP
65 Comments:
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 ?
[cc lang="vb"]Set newItems = itms.Restrict("[attachment] > 0")[/vb]
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?
Sub SaveAllAttachments(ByVal folderName As String, _ 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 FunctionThis 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:
Sub tst() Dim foldername As String foldername = "C:\XMLDemo\PriceAck\" Call SaveAllAttachments(foldername, True) End SubJP,
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 Compare Database 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 FunctionPlease 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.
Hi there,
I have a macro to print my attachments but I would like to delete them from this folder once they have printed. This is what I have so far: I have tried to add the Delete command but it only comes back with errors or only deletes a few items and leaves the rest. Any help would be great. thanks
Public Sub PrintAttachment() Dim Inbox As MAPIFolder Dim Item As MailItem Dim Atmt As Attachment Dim FileName As String Dim I As Integer Set Inbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders.Item("EFax") I = 0 For Each Item In Inbox.Items For Each Atmt In Item.Attachments FileName = "C:\Temp\" & Atmt.FileName Atmt.SaveAsFile FileName Shell """C:\Program Files\Adobe\Reader 9.0\Reader\acrord32.exe"" /h /p """ + FileName + """", vbHide I = 1 + 1 Next Atmt Next Item End SubIf you want to delete, you need to loop backwards. So a For Each Loop will not work.
I don't see what the I variable is doing in your code above, so we can repurpose it.
For Each Item In Inbox.Items For I = Item.Attachments.Count To 1 Step -1 ' save and print attachment here Item.Item(I).Delete Next i Next ItemHi, and thanks for the Macro. Is it possible to leave the creation date of the attachment unchanged. I want to save the attachments and later sort by date. If this is possible, how do I go back in and reset the attachments so that I can pull them out again?
Thanks again,
Tom
I don't see where the code changes the creation date of the attachment. That's part of the attachment file's metadata and wouldn't be affected by anything done here.
If you want to save the attachments, and then re-save them again later, call the procedure with False as the second argument (I tried to explain this in the article). The attachments will be saved, but not removed from the messages.
JP,
Thanks for the quick response. Yes, you are correct the file maintains its origination date. Is it possible to date the saved file with the date of the eMail message?
Tom
Sure, just do something like this:
MsgAttach.item(attachmentNumber).SaveAsFile _
folderName & Format(Msg.ReceivedTime, "mmddyyyyhhmmss") & MsgAttach.item(attachmentNumber).FileName
This would prepend the email reeceived time to the filename when saving.
JP,
Thanks again. I am not a code writer person. Where do I add those lines?
Tom
Tom,
Copy and paste the code from the article into a standard module in Outlook's VB Editor.
See Where do I put my Outlook VBA code? for placement assistance.
Then all you need to do is swap out the line that starts "MsgAttach.item(attachmentNumber).SaveAsFile" with the line I posted in my reply to your comment.
Hi JP!
Can you help me? I need to be able to extract attachments from a public folder rather than an inbox or inbox sub folder.
Is this possible? If so, how can your code be modified todo this?
Steve
The simplest way would be to change this line
to
but you could also write
Set olFldr = Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("My Folder").Folders("My Sub Folder")This subroutine will save all attachments found in a user specified Outlook folder to a user specified directory on the file system. It also updates each message with a link to the purged files.
It also contains extra comments to help highlight how the .Delete method will shrink Attachment containers dynamically (search for "~~" in the comments).
This macro is only tested on Outlook 2010.
' ------------------------------------------------------------. ' Requires the following references: ' Visual Basic for Applications ' Microsoft Outlook 14.0 Object Library ' OLE Automation ' Microsoft Office 14.0 Object Library ' Microsoft Shell Controls and Automation ' ------------------------------------------------------------. Public Sub SaveOLFolderAttachments() ' Ask the user to select a file system folder for saving the attachments Dim oShell As Object Set oShell = CreateObject("Shell.Application") Dim fsSaveFolder As Object Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1) If fsSaveFolder Is Nothing Then Exit Sub ' Note: BrowseForFolder doesn't add a trailing slash ' Ask the user to select an Outlook folder to process Dim olPurgeFolder As Outlook.MAPIFolder Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder If olPurgeFolder Is Nothing Then Exit Sub ' Iteration variables Dim msg As Outlook.MailItem Dim att As Outlook.attachment Dim sSavePathFS As String Dim sDelAtts For Each msg In olPurgeFolder.Items sDelAtts = "" ' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0") ' on our olPurgeFolder.Items collection. The collection returned by the Restrict method ' will be dynamically updated each time we remove an attachment. Each update will ' reindex the collection. As a result, it does not provide a reliable means for iteration. ' This is why the For Each style loops will not work. ~~ If msg.Attachments.Count > 0 Then ' This While loop is controlled via the .Delete method which ' will decrement msg.Attachments.Count by one each time. ~~ While msg.Attachments.Count > 0 ' Save the attachment to the file system sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName msg.Attachments(1).SaveAsFile sSavePathFS ' Build up a string to denote the file system save path(s) ' Format the string according to the msg.BodyFormat. If msg.BodyFormat <> olFormatHTML Then sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">" Else sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>" End If ' Delete the current attachment. We use a "1" here instead of an "i" ' because the .Delete method will shrink the size of the msg.Attachments ' collection for us. Use some well placed Debug.Print statements to see ' the behavior. ~~ msg.Attachments(1).Delete Wend ' Modify the body of the msg to show the file system location of ' the deleted attachments. If msg.BodyFormat <> olFormatHTML Then msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts Else msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>" End If ' Save the edits to the msg. If you forget this line, the attachments will not be deleted. ~~ msg.Save End If Next End SubLooks great, but since you are late binding the Shell application, I don't see why you would need to reference the typelib.
I used RNV's code and it works great!
However, is there a way to change the code so that I can save to a specific (same) folder rather than browsing to one all the time? I was trying to use some of the code information above but cannot figure this out.
This line stores the path from the user selection:
If you want to hardcode the folder, you could change this line to point to the folder, i.e.
You could then remove the code that browses for the folder.
SWEET!
As option two worked perfectly, another issue came up.
I had duplicate file names. So three files did not transfer.
Is there a way to rename duplicates during transfer?
There are a few things you could do:
1) Get a count of files in the folder. Prepend this number to the filename.
2) Generate a random number and prepend it to the filename.
3) Before saving the file, check if the filename already exists in the folder. Start a loop that adds an incrementing number to the filename and then check if that filename exists. If it doesn't, save the file using that filename.
4) Prepend the email's received time to the filename (i.e. Format$(Msg.ReceivedTime, "mmddyyyyhhmmss") is likely to be a unique string for different emails)
Option 4 sounds like a plan to go with, but I don't know where to place that string at in the code.
It should be concatenated with the existing filename:
MsgAttach.item(attachmentNumber).SaveAsFile _ folderName & Format$(Msg.ReceivedTime, "mmddyyyyhhmmss") & MsgAttach.item(attachmentNumber).FileNameI am sorry, must be Monday, where exactly do I place these strings in RNV's above code? Also do I have to edit these strings as well?
JP,
I got it. Works like a charm! You the Man!
Thanks for your help!
i seem to be having a problem with the code
1) The line
Set newItems = itms.Restrict("[Attachment] > 0")doesn't seem to exclude items without attachments
2) The line
fails with a object variable not set error. if i replace the
line with
, the code works.
3) my final issue is looping through a folder that contains unactioned meeting requests. if the meeting request is the first item the code breaks at the
line. If the meeting request is a subsequent item it breaks at
. In both cases the error is 13 Type Mismatch and when i hover oiver the 'Msg' word intellitype shows 'Nothing' . i'm not sure if this is restricted to meeting request items but i have tried it with other calendar and task items and i can't recreate the error. Is it possible to restrict the newItems collection to 'having attachment and not a meeting request'? i've tried using Set newItems = itms.Restrict("[Attachment] > 0 AND [MessageClass] 'Meeting Request'")[/vb] but i couldn't get it to work possibly related to my issue 1.
I also wonder if there a list of available filter strings and their possible criteria any where (MSDN wasn't very helpful)?
Can you help?
@Lee:
1) Outlook considers things like images in signatures to be attachments. So that might be what is going on here.
2) Without seeing your code, it's hard to diagnose, because in the original if there are no items with attachments (even bogus attachments) the code exits. Your correction works as long as there are any kind of items in the Inbox.
3) If you are running this code on meeting requests, that explains why the code won't work. As written, it's meant to be used on emails. The code does assume that the Inbox contains only emails, otherwise the For Each loop will fail. I didn't mention that in the article, I will amend it now.
The Restrict Method documentation on MSDN tells you which item properties cannot be used in a Restrict expression. Anything not listed there is fair game.
Sub SaveAtt() 'Save multiattachment from selected emails Dim myOl As Outlook.Application Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim myItem As Outlook.MailItem Dim myAttachment As Outlook.Attachments Dim i As Integer Dim j As Integer Dim k As Integer 'work on selected items Set myOl = CreateObject("Outlook.Application") Set myOlSel = ActiveExplorer.Selection For i = 1 To myOlSel.Count Set myItem = myOlSel.Item(i) For j = 1 To myItem.Attachments.Count With myItem.Attachments.Item(j) .SaveAsFile "C:\" & .FileName k = k + 1 End With Next j Next i MsgBox (k & " files saved") Set myItems = Nothing Set myItem = Nothing Set myAttachments = Nothing Set myAttachment = Nothing Set myOl = Nothing Set myOlExp = Nothing Set myOlSel = Nothing End SubThanks for the code, dc!
If you're using the code in Outlook, you wouldn't use CreateObject with the Outlook Application object. You can set a reference directly.
If you're using the code in Excel, you should note that you need to manually set a reference to the Excel object library beforehand.
Also note that your code doesn't offer the option to delete the attachments.
Just wanted to say thanks – Your original code worked fine. I did not want it to use my main mailbox, but one that was added. I used the getdolder code on a link, and no problems at all. Thanks again. You have saved me a lot of time every day!
Hi,
What in case when I have a few emails with the same name of attachment ? I can see that attachment is overwrite automaticly
Brgds
m@cias
Incorporate msg.ReceivedTime into the filename, i.e.
MsgAttach.item(attachmentNumber).SaveAsFile _ folderName & Format(msg.ReceivedTime, "mm/dd/yyyy hh:mm:ss") & MsgAttach.item(attachmentNumber).FileNamewhere i write the code
MsgAttach.item(attachmentNumber).SaveAsFile _
folderName & Format(msg.ReceivedTime, "mm/dd/yyyy hh:mm:ss") & MsgAttach
Please specify as i do not know vba fully.
Hi,
Can any one post a code on how to convert all attachments as one PDF and save it in physical drive ..
please give me the vba code that helps me only excel attachment files are saved in a folder.
I'd like to help you, but I can't write your code for you. You'll need to add a condition inside the For Loop of the SaveAllAttachments procedure that checks if the file is an Excel file.
I tried your code and it won't work at all…I've tried giving it a hierarchy to follow, and the pickfolder to no avail. I have tried a hard drive folder in my cpu and a shared hdd on our enterprise server. When I run it, nothing happens…here is the code I am trying to run:
Step through the code by pressing F8 repeatedly. Does the code error out on any line?
I stepped through completely with F8 and all I get are yellow steps without any errors. It would seem that the macro is "working", but nothing is saving to any folders on my HDD… I don't even get the option to "PickFolder" per this code line:
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items
Very weird that nothing works…
To add to it, I have another code that I inserted the code (below) and that one will allow the folder selection tool window to pop up both by stepping through and also when executed, however that still gives and error after. I posted the new code below your "pickFolder" code.
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items
New code:
Sub SaveEmailAttachmentsToFolder() Dim ns As NameSpace Dim Inbox As MAPIFolder Dim SubFolder As MAPIFolder Dim Item As Object Dim Atmt As Attachment Dim FileName As String Dim MyDocPath As String Dim I As Integer Dim wsh As Object Dim fs As Object On Error GoTo ThisMacro_err ' get default Inbox items collection Dim olFldr As Outlook.MAPIFolder Dim itms As Outlook.Items Set olFldr = Outlook.GetNamespace("MAPI").PickFolder If olFldr Is Nothing Then Exit Sub Set itms = olFldr.Items I = 0 ' Check subfolder for messages and exit of none found If SubFolder.Items.Count = 0 Then MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _ vbInformation, "Nothing Found" Set SubFolder = Nothing Set Inbox = Nothing Set ns = Nothing Exit Sub End If 'Create DestFolder if DestFolder = "" If DestFolder = "C:\Documents and Settings\bpedersen\Email test" Then Set wsh = CreateObject("WScript.Shell") Set fs = CreateObject("Scripting.FileSystemObject") MyDocPath = wsh.SpecialFolders.Item("mydocuments") DestFolder = MyDocPath & "C:\Documents and Settings\bpedersen\Email test" & Format(Now, "dd-mmm-yyyy hh-mm-ss") If Not fs.FolderExists(DestFolder) Then fs.CreateFolder DestFolder End If End If If Right(DestFolder, 1) <> "\" Then DestFolder = DestFolder & "\" End If ' Check each message for attachments and extensions For Each Item In SubFolder.Items For Each Atmt In Item.Attachments If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then FileName = DestFolder & Item.SenderName & " " & Atmt.FileName Atmt.SaveAsFile FileName I = I + 1 End If Next Atmt Next Item ' Show this message when Finished If I > 0 Then MsgBox "You can find the files here : " _ & DestFolder, vbInformation, "Finished!" Else MsgBox "No attached files in your mail.", vbInformation, "Finished!" End If ' Clear memory ThisMacro_exit: Set SubFolder = Nothing Set Inbox = Nothing Set ns = Nothing Set fs = Nothing Set wsh = Nothing Exit Sub ' Error information ThisMacro_err: MsgBox "An unexpected error has occurred." _ & vbCrLf & "Please note and report the following information." _ & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" Resume ThisMacro_exit End Sub