Save all attachments from selected folder

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

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 to learn more about VBA. Keep Reading »



Share This Article:

Share and bookmark this articledelicious buttonfacebook buttonlinkedin buttonstumbleupon buttontwitter button

comment bubble 65 Comment(s) on Save all attachments from selected folder:

  1. Philippe writes:

    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

  2. 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.

  3. Dylan writes:

    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.

  4. 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

  5. Thank you for the code. This is great. Just what I was looking for.

  6. 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.

  7. 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

  8. 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 ?

    Set newItems = itms.Restrict("[attachment] > 0")

    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.

  9. Craig Z writes:

    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?

      • Craig Z writes:

        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?

        • Craig Z writes:
          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 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:

          Sub tst()
          
          Dim foldername As String
              foldername = "C:\XMLDemo\PriceAck\"
          
             Call SaveAllAttachments(foldername, True)
          
          End Sub
        • Craig Z writes:

          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 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 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.

  10. Alan C writes:

    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

  11. Chelle writes:

    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.

  12. Stephanie writes:

    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 Sub
    • If 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 Item
  13. Hi, 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.

  14. 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.

  15. 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.

  16. 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

      Set olFldr = GetDefaultFolder(olFolderInbox)

      to

      Set olFldr = Session.PickFolder

      but you could also write

      Set olFldr = Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("My Folder").Folders("My Sub Folder")
  17. 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 Sub
    
    
    • Looks 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:

        sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName

        If you want to hardcode the folder, you could change this line to point to the folder, i.e.

        sSavePathFS = "C:\MyFolder\" & msg.Attachments(1).FileName

        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).FileName
        • I 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!

  18. 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

    Set MsgAttach = Msg.Attachments

    fails with a object variable not set error. if i replace the

    For Each Msg In newItems

    line with

    For Each Msg In itms

    , 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

    For Each Msg In newItems

    line. If the meeting request is a subsequent item it breaks at

    Next Msg

    . 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.

  19. dreamcast writes:
    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 Sub
    • Thanks 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.

  20. Richiee writes:

    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!

  21. 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).FileName
      • trinath writes:

        where 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.

  22. Hi,

    Can any one post a code on how to convert all attachments as one PDF and save it in physical drive ..

  23. 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.

  24. 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:

    Public Sub SaveAllAttachments()
    ' 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 = "C:\Documents and Settings\bpedersen\Email test"
    End If
     
    ' 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
     
    ' create subset of items collection
    Dim newItems As Outlook.Items
    Set newItems = itms.Restrict("[Attachment] &gt; 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 &amp; MsgAttach.Item(attachmentNumber).FileName
        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
    • 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
This article is closed to any future comments.
Peltier Tech Charting Utilities for Excel