Enhancing the Save Attachments Outlook Macro

Development, Outlook, VBScript 2 Minutes

Update: Feb. 28, 2007: Due to numerous requests I’ve created a branch of this macro that saves attachments for all messages / calendar items, selected or not. To see it, please see my post https://arcanecode.wordpress.com/2007/02/28/saving-all-attachments-in-outlook/ or http://shrinkster.com/mhn. There I have uploaded a new file with both the macro below and the new one that saves all items, selected or not.

Yesterday I blogged about a macro I wrote for my wife to allow her to save attachments for multiple messages in Outlook. After using it today she asked for a few enhancements. First, she wanted to be able to select the directory to save the attachments to. Second, she wanted the macro to detect that a file already existed, and allow her to rename the new file or skip it.

To accomplish the first item, I found a handy routine in a google groups thread. I’ll let you read it for yourself, the code is about half way down in a message by Joe Earnest, and can be found at http://shrinkster.com/l0v. I took Joe’s code and created a function out of it called GetOutputDirectory. I made one enhancement, at the end I make sure the output directory ends in a backslash.

For the second enhancement I used the good old scripting runtime library. Use the Tools, References menu in the VBScript editor and set a reference to the “Microsoft Scripting Runtime”, scrrun.dll. Rather than reposting all the code I’ve put the entire macro in a txt file you can download here: https://arcanecode.files.wordpress.com/2007/01/saveattachments2.txt

Here is the heart of the code

fileExists = fso.fileExists(outputDir + outputFile)

Do While fileExists = True
outputFile = InputBox(“The file ” + outputFile _
+ ” already exists in the destination directory of ” _
+ outputDir + “. Please enter a new name, or hit cancel to skip this one file.”, “File Exists”, outputFile)
‘If user hit cancel
If outputFile = “” Then
‘Exit leaving fileexists true. That will be a flag not to write the file
Exit Do
End If
fileExists = fso.fileExists(outputDir + outputFile)
Loop

‘Save it to disk
If fileExists = False Then
att.SaveAsFile (outputDir + outputFile)
AttTotal = AttTotal + 1
End If

As you can see, I check to see if the file exists and store that in a variable. I then enter a loop if the file exists, ask for a new name, then check to see if the new name exists. I stay in the loop as long as it does.

Should the user click the cancel button on the input box, I exit the loop prematurely and use the fileexists as a flag to write or not write the file.

There you go, an enhanced version of the SaveAttachments macro. Take a look at the full file I’ve uploaded, and leave a comment with any questions.

Published by arcanecode

Published

66 thoughts on “Enhancing the Save Attachments Outlook Macro”

  1. Wonderful script! One question though, I am attempting to use this to clear the attachments from my calendar. It seems to only work on the days I highlight. Is there a way to get it to remove all attachments in the calendar just by selecting the calendar in the folder view? Again, it seems I have to select each day individually.

    Reply

  2. Instead of cycling through the collection of selected items (the for cnt = 1 to Sel.Count area) you’ll want to cycle through the calendar folder. I’ll have to dig a bit to get the exact code, meanwhile you could always just do a Ctrl+A (Edit, Select All on the menu) to select all the items then run the script.

    I wrote the macro as a Christmas present to my wife, who wanted to save only messages she had selected, hence the way it was written.

    Reply

  3. Thank you for your time with this, I really appreciate it.

    Unfortunatelly, CTRL+A doesnt work in the calendar. (I actually tried all variations prior to bugging you!) 🙂

    Dont kill yourself, but if you could come up with something it would be wonderful.

    Thanks Again!

    Reply

  4. Just wanted to thank you for an extremely useful piece of code. I get dozens of attachments from many of my writers every day, and having to save each message’s attachments individually has been time-consuming. One program I found did work well, but of course, was not free. Your macro works great. Thanks!

    Julie

    Reply
  5. Pingback: Saving All Attachments in Outlook « Arcane Code

  6. This is a brilliant bit of code. so useful i get loads of attachments which i want to save.

    I have messsages with attachments which have been forwarded, some times the file i want is 4 or more messages in. it saves the .msg file and not the jpg file i want. if there anyway aound this ?

    Reply

  7. Hi There

    Thanks for the brilliant piece of code!.
    I have however one question as I would like to save the attachments to a network share, but if I change the destination folder to \\server\sharename then it says unable to save attachments even though everyone can save to the folder. Any ideas please?

    Reply

  8. Great bit of code – thanks!
    Just a thought – I edited it to prefix the attachment with the subject of the email so that attachments will get similar names. I also had to filter out invalid characters.

    🙂

    Reply

  9. Helpful site – thanks.

    I don’t supposed there’s a way to append the attachment to the existing file? after you checked if file already exists.

    Any suggestion would be greatly appreciated.

    Reply

  10. Just the code I have been looking for – thanks!

    Unfortunately, I get an error when running the macro: “Compile error: User-defined type not defined” when the code reaches “Dim fso As FileSystemObject”

    Any idea why?

    Thanks in advance!

    Reply

  11. @ Kenneth:

    In the VB editor in Outlook, under the ‘extra’ menu, there should be something like a ‘references’ option.
    Scroll through the list until you find “Microsoft Scripting Runtime”.

    Reply

    1. In Office 07 (Professional?) the ‘References…’ otion is in the ‘Tools’ menu, for those who can’t find the ‘extra’ menu.
      Great Code!

      Reply

  12. From a salesguy with no coding experience. Can some one please post step by step Install or Implementation instructions? Thanks for your help this looks like what I need. I have 400+ emails with .jpg atttachments that I need to extract and post on my website. Any reco’s are appreciated.

    Thanks!

    Reply

  13. Very nice script! Thanks for making it available

    Sam, to install this macro open Outlook, click Tools – Macro – Visual Basic Editor. From there, click Insert New Module. Copy and Paste the script into the blank module that opens. Then click Tools – References and choose Microsoft Windows Scripting. Finally, click save.

    To run it click Tools – Macro – Macros, or hit Alt-F8 to bring up the macros window.

    Reply

  14. If i can get this to work it will save me about an hour every day, but I get the
    “Compile error: User-defined type not defined” when the code reaches “Dim fso As FileSystemObject” problem.
    When i go to the references menu on the vb editor there isn’t a microsoft scripting runtime or a microsoft windows scripting option.
    I’m using outlook 2003 with no disabled items.

    Reply

  15. Simon: Check the paragraph right before the code. You will need to set a reference to the scripting runtime library, which is likely why you are getting the error.

    Reply

  16. Thanks for sharing!

    One question: I would like to use the macro to detach the images my webcam sends to my email adress every 10 minutes. The webcam always uses the same file name, and I would like to use the date/time of the image as (part of) the new file name.
    Is there any way I can get hold of those properties of the attached image file? Or any other way that would make the images distinguishable?
    Suggestions greatly appreciated!

    Reply

  17. Cheers for the great script.

    WOuld like to know how to change the email folder if you don’t want the Inbox as the default folder to get the attachments from eg i have a rule to place orders from the inbox into the orders folder in outlook. Tried and failed to get it to work.

    Reply

  22. Wonderful macro; extremely helpful. I’m not a VBA coder, but I would like to save my attachments with the date/time stamp of the message. For example, if the message containing the attachments was received on 01/12/2009 at 10:00 am, I would like each attachment’s filename to appear as follows: FILENAME_20080112.1000.EXT.

    Would you be able to help me with the necessary code to implement this change to the macro? Thanks very much.

    Reply

    1. BTD,

      Did you get a response or figure out how to incorporate the date/time stamp when saving the attachments? I am in need of the same modification as I receive system generated reports only distinguished by the time stamp.

      GIB

      Reply

  23. I love the code. I wrote something similar. What I am trying to get mine to do is print the attachments (I’d like it to convert all files to .pdf, and the only way I know how is to print them using a convert to .pdf printer).

    Do you know how to tell VB to open, print, and close any file in that order?

    Reply

  25. Hello,

    I need help if anyone knows how to accomplish this. I receive an email which contains two attachments. Each attachment has the name of a city in it (88552_virginia.pdf) and (77558_calhoun.pdf). I need to rename & save each of the attachments into their own folder. Some how the script would need look for the name in the attachment then save to a folder based on the name of the attachment. I need to rename each file as ad.pdf and place them in two separate folders. Then I have an ftp program that automatically uploads the file to a website from that point.

    Summary:

    2 email attachments in one email (88552_virginia.pdf) and (77558_calhoun.pdf).

    The script needs to pick out the name of the attachment by looking for “virginia” or “calhoun” and save each to their own folder with a rename to ad.pdf

    My folders would be
    /virginia/ads/
    /calhoun/ads/

    I greatly appreciate any help. Thanks!

    Reply
  32. Pingback: Tpico da Informtica - se informtica, vem parar aqui! - Pgina 102 - FRUM AUTOHOJE ONLINE

  33. To all that want to save files in a non-standard way (example: with date stamping, in special dirs etc).

    You need to change the outputFile, possibly the outputDir in the line

    outputFile = att.FileName

    Example: if outputFile = “attach01.jpg” and you want “attach01_2007-03-19_02-24-25.jpg”, all you need to do is some string manipulation.

    If you define a new variable as “MailItem” you can use
    set mailitemvar = sel.item(cnt)

    Then it’s easy to access the properties for sel.item(cnt). Example: ReceivedTime. You can format as per standard VBA using format().

    Reply

  36. Exactly what I needed. Worked perfectly.
    Would have been nice if it remembered the last directory I saved the files to, but other than that it’s excellent. Great work!

    Reply

  41. Great script, thanks. I had no idea that you could have macros in outlook 🙂

    Just a quick question: Why not just use the “Dir” function in the macro to find out if the file exists rather than using the FileSystemObject?

    fileExists = Not Dir(outputDir + outputFile) = vbNullString

    Reply

  42. Thank-you very much. I’ve been trying to teach myself enough VB to write this for myself, and it hasn’t been going well.

    Reply

  43. Love this macro! I scan a lot of docs to PDF in bulk (receipts, bills, etc) and love being able to extract them all so quickly and efficiently.

    My prob is that when I scan a ton of documents at once, they all have the same name (i.e. “scan.pdf”) and having to rename each of them manually is time-consuming even with the input box. I tried to play around with the macro to automatically number each document based on the message number and it worked (i.e. “scan1.pdf”, “scan2.pdf”, etc) but it keeps crashing at 100. Ugh. I tried to troubleshoot as best as I could but haven’t nailed it yet.

    REQUEST: any chance of a version of this that would do exactly that – i.e. rather than manually renaming, check for a document with the same filename and then just append the next in a sequential list of numbers to the document filename?

    Regardless, great macro! Thanks! 🙂

    Reply

    1. Maybe I’m not crazy, after all. 🙂

      Tested the original macro with 100+ messages and it stopped/crashed after the 100th message/attachment. Any idea what it could be?

      Thanks again! 🙂

      Reply

      1. The script opens up the message (and keeps them open) as it iterates over the messages and saves the attachments. I edited the script so that it processes a subset of the messages at a time and this issue went away.

        I have attached the code below but am not sure how to format it correctly (so apologies for formatting of code).

        Option Explicit

' Using code from:
' https://arcanecode.com/2007/01/03/enhancing-the-save-attachments-outlook-macro/
'       https://arcanecode.files.wordpress.com/2007/01/saveattachments2.txt
' http://www.rondebruin.nl/mail/folder2/saveatt.htm
' http://www.vbaexpress.com/kb/getarticle.php?kb_id=767


Public Sub SaveAttachments()

    ' Note, this assumes you are in the a folder with e-mail messages when you run it.
    ' It does not have to be the inbox, simply any folder with e-mail messages
    Dim attachmentCount As Integer
    Dim messageCount As Integer


    Dim outlookApp As New Outlook.Application
    Dim folder As Outlook.Explorer
    Set folder = outlookApp.ActiveExplorer


    Dim outputDir As String
    outputDir = GetOutputDirectory()
    If outputDir = "" Then
        MsgBox "You must pick a directory to save your files to. Exiting SaveAttachments.", vbCritical, "SaveAttachments"
        Exit Sub
    End If


    ' Loop thru each selected item in the inbox (100 at a time)
    Const stepSize = 100
    Dim currentIndex As Integer
    currentIndex = 1
    Do While currentIndex < folder.Selection.Count
        Call ProcessChunk(folder.Selection, currentIndex, currentIndex + stepSize - 1, outputDir, attachmentCount, messageCount)
        currentIndex = currentIndex + stepSize
    Loop

    ' Clean up
    Set folder = Nothing
    Set outlookApp = Nothing

    ' Let user know we are done
    Dim doneMsg As String
    doneMsg = "Completed saving " + Format$(attachmentCount, "#,0") + " attachments in " + Format$(messageCount, "#,0") + " Messages."
    MsgBox doneMsg, vbOKOnly, "Save Attachments"

    Exit Sub

ErrorHandler:

    Dim errMsg As String
    errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description
    Dim errResult As VbMsgBoxResult
    errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")
    Select Case errResult
        Case vbAbort
            Exit Sub
        Case vbRetry
            Resume
        Case vbIgnore
            Resume Next
    End Select

End Sub


' Process a "chunk" of the selected messages starting at startIndex and finishing at endIndex.
' The attachments are saved in outputDir and the 'statistics' parameters are modified (attachmentCount and messageCount)
Private Sub ProcessChunk(selection As Outlook.selection, _
            startIndex As Integer, endIndex As Integer, outputDir As String, _
            ByRef attachmentCount As Integer, ByRef messageCount As Integer)
    Dim outputFile As String
    Dim msgAttachement As Attachment

    Dim index As Integer
    For index = startIndex To endIndex
        If index <= selection.Count Then
            messageCount = messageCount + 1

            For Each msgAttachement In selection.Item(index).Attachments

                If msgAttachement.Type  olOLE Then
                    outputFile = msgAttachement.filename
                    Dim uniqueFilename As String
                    uniqueFilename = GetUniqueFilename(outputDir, outputFile)
                    msgAttachement.SaveAsFile (outputDir + uniqueFilename)
                    attachmentCount = attachmentCount + 1
                End If
            Next msgAttachement
        End If
    Next index
End Sub


' If the filename already exists, add a counter to the filename (before the extension)
Public Function GetUniqueFilename(directory As String, filename As String) As String
    Dim uniqueFilename As String
    Dim index As Integer

    uniqueFilename = filename
    index = 1
    Do While Not Dir(directory + uniqueFilename) = vbNullString
        uniqueFilename = FileNameNoExtension(filename) + "_" + Format(index, "000") + "." + FileNameExtensionOnly(filename)
        index = index + 1
    Loop
    GetUniqueFilename = uniqueFilename
End Function


' returns the filename without the extension from the file's full path
Function FileNameNoExtension(strPath As String) As String
    Dim strTemp As String
    strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
    FileNameNoExtension = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function

' returns the filename with the extension from the file's full path
Function FileNameWithExtension(strPath As String) As String
    FileNameWithExtension = Mid$(strPath, InStrRev(strPath, "\") + 1)
End Function

' returns the filename without the extension from the file's full path
Function FileNameExtensionOnly(strPath As String) As String
    Dim strTemp As String
    strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
    FileNameExtensionOnly = Mid$(strTemp, InStrRev(strTemp, ".") + 1)
End Function

' returns the path only (i.e. the folder) from the file's full path
Function FilePath(strPath As String) As String
    FilePath = Left$(strPath, InStrRev(strPath, "\"))
End Function


' Display a file dialog to select the target directory
' Found this code in a google groups thread here:
' http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
' or http://shrinkster.com/l0v
Public Function GetOutputDirectory() As String

    Dim retval As String 'Return Value

    Dim sMsg As String
    Dim cBits As Integer
    Dim xRoot As Integer

    Dim oShell As Object
    Set oShell = CreateObject("shell.application")

    sMsg = "Select a Folder To Output The Attachments To"
    cBits = 1
    xRoot = 17

    On Error Resume Next
        Dim oBFF
        Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
        If Err Then
            Err.Clear
            GetOutputDirectory = ""
            Exit Function
        End If
    On Error GoTo 0

    If Not IsObject(oBFF) Then
        retval = ""
    Else If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = "folder") Then
        retval = ""
    Else
        retval = oBFF.self.path

        ' Make sure there's a trailing "\"
        If Right(retval, 1)  "\" Then
            retval = retval + "\"
        End If
    End If

    GetOutputDirectory = retval

End Function

    2. Jeremy,

      Would you mind posting up the code that you altered to append a 1, 2, 3, etc… to the end of the filenames? I am also trying to find a way to append sequential numbers to the end of the filenames, as I may have thousands of attachments to save…!

      But indeed, a great macro all up.

      Cheers 🙂

      Reply

      1. I added this function to get a unique filename:

        ‘ If the filename already exists, add a counter to the filename (before the extension)
        Public Function GetUniqueFilename(directory As String, filename As String) As String
        Dim uniqueFilename As String
        Dim index As Integer

        uniqueFilename = filename
        index = 1
        Do While Not Dir(directory + uniqueFilename) = vbNullString
        uniqueFilename = FileNameNoExtension(filename) + “_” + Format(index, “000”) + “.” + FileNameExtensionOnly(filename)
        index = index + 1
        Loop
        GetUniqueFilename = uniqueFilename
        End Function

      2. My apologies – I don’t know VB so I just read other syntax and hacked this version together. It was only suited for my purposes where I knew that the filename would be four characters long. I modified (with humble apologies for the format) only one section of the original arcanecode macro:

        * * * *
        ‘Loop thru each selected item in the Inbox
        For cnt = 1 To Sel.Count
        ‘If the email message has attachments …
        If Sel.Item(cnt).Attachments.Count > 0 Then
        MsgTotal = MsgTotal + 1
        ‘For each attachment on the message …
        For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
        ‘Get the attachment
        Dim att As Attachment
        Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)
        If MsgTotal < 10 Then
        outputFile = Left(att.filename, 4) + "00" + CStr(MsgTotal) + ".pdf"
        ElseIf MsgTotal < 100 Then
        outputFile = Left(att.filename, 4) + "0" + CStr(MsgTotal) + ".pdf"
        Else
        outputFile = Left(att.filename, 4) + CStr(MsgTotal) + ".pdf"
        End If
        att.SaveAsFile (outputDir + outputFile)
        AttTotal = AttTotal + 1
        Next
        End If
        Next
        * * * *

        Again, it works for me in that it extracts all the attachments and appends a number to the filename but for some reason (with this code and with the original code) it crashes after 100 messages/attachments. Still haven't figured that part out yet, tho'.

        Cheers,
        Jeremy 🙂

  44. Thanks for the quick responses guys! Could someone please tell me where in the original Arcane code you are meant to insert the Function code that Josh posted…? Unfortunately I only have a basic VB understanding.

    Cheers again 🙂

    Mike

    Reply

  46. Was trying to get the txt file for this code and simply cannot. I even started a blog account I will never use to get it and still not being granted access.

    Reply

  50. I keep getting a Compile error: Syntax error on “outputFile = InputBox(“The file ” + outputFile _”
    Can anyone offer assistance on what I might be doing wrong. Thanks

    Reply

  51. Wow, thanks so much! Amazing. Good input and help from those who got it working. All the answers are there. The only problem I had was with the reposted code. Use the direct txt link post if possible.

    Reply

  57. Hi alll…. i was wondering after seeing all your msgs that whether this macro could help me in my work. if not Pls help me in puting a macro for the following work that we carry on.

    Overview of the process that we do.

    Customer applies for a product online, the details/data comes to the Manager as mails. he then saves those mails as .txt to a common drive, from which we take those cases and proceeds with our work… there would be above 1500cases a day. and its very tough to keep saving each mail that comes in outlook, it takes very long time. while saving a mail we mention the number as well, the file name would be for example:- 1.pepsi,2.pepsi,3.coke….. like wise for each file we add the seriel number to identify the number of cases that comes a day…

    Kindly help me in creating a macro from the outlook to solve this issue, it would be a great help if i could get this done…

    THANKS IN ADVANCE..

    Reply

  58. Hey all,

    Again, big props to Robert for this great macro which has saved me tons of time. Updated below with my own hack to append a “-0000” numerical sequence to the end of the files. No longer crashes after 100 files, either:

    ========
    Option Explicit

    Public Sub SaveAllAttachmentsSequentialRename()
    ‘Note, this assumes you are in the a folder with e-mail messages when you run it.
    ‘It does not have to be the inbox, simply any folder with e-mail messages

    Dim App As New Outlook.Application
    Dim Exp As Outlook.Explorer
    Dim Sel As Outlook.Items

    Dim AttachmentCnt As Integer
    Dim AttTotal As Integer
    Dim MsgTotal As Integer

    Dim outputDir As String
    Dim outputFile As String
    Dim fileExtension As String
    Dim fileExists As Boolean
    Dim cnt As Integer
    Dim cntx As Integer

    ‘Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL)
    Dim fso As FileSystemObject

    Set Exp = App.ActiveExplorer
    Set Sel = Exp.CurrentFolder.Items
    Set fso = New FileSystemObject

    outputDir = GetOutputDirectory()
    If outputDir = “” Then
    MsgBox “You must pick a directory to which the macro will save attachments. Exiting macro …”, vbCritical, “SaveAttachmentsSequentialRename”
    Exit Sub
    End If

    ‘Loop thru each selected item in the inbox
    For cnt = 1 To Sel.Count
    ‘If the email message(s) has/have attachments…
    If Sel.Item(cnt).Attachments.Count > 0 Then
    MsgTotal = MsgTotal + 1

    ‘For each attachment on the message …
    For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
    ‘Get the attachment
    Dim att As Attachment
    Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)

    outputFile = Left(att.FileName, InStr(att.FileName, “.”) – 1)
    fileExtension = Right(att.FileName, (Len(att.FileName) – InStrRev(att.FileName, “.”)))
    fileExists = fso.fileExists(outputDir + outputFile + “.” + LCase(fileExtension))

    Do While fileExists = True
    cntx = cntx + 1

    Select Case cntx
    Case Is < 10
    outputFile = outputFile + "-000" + Right(Str(cntx), 1)
    Case Is < 100
    outputFile = outputFile + "-00" + Right(Str(cntx), 2)
    Case Is < 1000
    outputFile = outputFile + "-0" + Right(Str(cntx), 3)
    End Select

    'outputFile = InputBox(ìThe file î + outputFile _
    + î already exists in the destination directory of î _
    + outputDir + ì. Please enter a new name, or hit cancel to skip this one file.î, ìFile Existsî, outputFile)

    'If user hit cancel
    If outputFile = "" Then
    'Exit leaving fileexists true. That will be a flag not to write the file
    Exit Do
    End If

    fileExists = fso.fileExists(outputDir + outputFile + "." + LCase(fileExtension))
    Loop

    'Save it to disk if the file does not exist
    If fileExists = False Then
    att.SaveAsFile (outputDir + outputFile + "." + LCase(fileExtension))
    AttTotal = AttTotal + 1
    End If
    Next
    End If
    Next

    'Clean up
    Set Sel = Nothing
    Set Exp = Nothing
    Set App = Nothing
    Set fso = Nothing

    'Let user know we are done
    Dim doneMsg As String
    doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
    MsgBox doneMsg, vbOKOnly, "Save Attachments"

    Exit Sub

    ErrorHandler:
    Dim errMsg As String
    errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description

    Dim errResult As VbMsgBoxResult
    errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")

    Select Case errResult
    Case vbAbort
    Exit Sub

    Case vbRetry
    Resume

    Case vbIgnore
    Resume Next
    End Select

    End Sub

    'Found this code in a google groups thread here:
    'http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
    'or http://shrinkster.com/l0v
    Public Function GetOutputDirectory() As String

    Dim retval As String 'Return Value

    Dim sMsg As String
    Dim cBits As Integer
    Dim xRoot As Integer

    Dim oShell As Object
    Set oShell = CreateObject("shell.application")
    sMsg = "Select Output Folder for Attachments"
    cBits = 1
    xRoot = 17

    On Error Resume Next
    Dim oBFF
    Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
    If Err Then
    Err.Clear
    GetOutputDirectory = ""
    Exit Function
    End If
    On Error GoTo 0

    If Not IsObject(oBFF) Then
    GetOutputDirectory = ""
    Exit Function
    End If

    If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = "folder") Then
    retval = ""
    Else
    retval = oBFF.self.Path

    'Make sure there's a \ on the end
    If Right(retval, 1) “\” Then
    retval = retval + “\”
    End If
    End If

    GetOutputDirectory = retval

    End Function

    ========

    Robert – thanks again.

    Cheers,
    Jeremy 🙂

    Reply

  59. Hey all,

    Robert – again thanks for a great macro. My hack here to append a “-0000” 4-digit numerical sequence to multiple files of the same name. Not great (i.e. 1st file doesn’t get the numerical sequence; multiple files with different names pick up the sequence rather than starting fresh; etc) but it does the trick for me. Also no longer having issue with crash after 100 files:

    ========
    Option Explicit

    Public Sub SaveAllAttachmentsSequentialRename()
    ‘Note, this assumes you are in the a folder with e-mail messages when you run it.
    ‘It does not have to be the inbox, simply any folder with e-mail messages

    Dim App As New Outlook.Application
    Dim Exp As Outlook.Explorer
    Dim Sel As Outlook.Items

    Dim AttachmentCnt As Integer
    Dim AttTotal As Integer
    Dim MsgTotal As Integer

    Dim outputDir As String
    Dim outputFile As String
    Dim fileExtension As String
    Dim fileExists As Boolean
    Dim cnt As Integer
    Dim cntx As Integer

    ‘Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL)
    Dim fso As FileSystemObject

    Set Exp = App.ActiveExplorer
    Set Sel = Exp.CurrentFolder.Items
    Set fso = New FileSystemObject

    outputDir = GetOutputDirectory()
    If outputDir = “” Then
    MsgBox “You must pick a directory to which the macro will save attachments. Exiting macro …”, vbCritical, “SaveAttachmentsSequentialRename”
    Exit Sub
    End If

    ‘Loop thru each selected item in the inbox
    For cnt = 1 To Sel.Count
    ‘If the email message(s) has/have attachments…
    If Sel.Item(cnt).Attachments.Count > 0 Then
    MsgTotal = MsgTotal + 1

    ‘For each attachment on the message …
    For AttachmentCnt = 1 To Sel.Item(cnt).Attachments.Count
    ‘Get the attachment
    Dim att As Attachment
    Set att = Sel.Item(cnt).Attachments.Item(AttachmentCnt)

    outputFile = Left(att.FileName, InStr(att.FileName, “.”) – 1)
    fileExtension = Right(att.FileName, (Len(att.FileName) – InStrRev(att.FileName, “.”)))
    fileExists = fso.fileExists(outputDir + outputFile + “.” + LCase(fileExtension))

    Do While fileExists = True
    cntx = cntx + 1

    Select Case cntx
    Case Is < 10
    outputFile = outputFile + "-000" + Right(Str(cntx), 1)
    Case Is < 100
    outputFile = outputFile + "-00" + Right(Str(cntx), 2)
    Case Is < 1000
    outputFile = outputFile + "-0" + Right(Str(cntx), 3)
    End Select

    'outputFile = InputBox(ìThe file î + outputFile _
    + î already exists in the destination directory of î _
    + outputDir + ì. Please enter a new name, or hit cancel to skip this one file.î, ìFile Existsî, outputFile)

    'If user hit cancel
    If outputFile = "" Then
    'Exit leaving fileexists true. That will be a flag not to write the file
    Exit Do
    End If

    fileExists = fso.fileExists(outputDir + outputFile + "." + LCase(fileExtension))
    Loop

    'Save it to disk if the file does not exist
    If fileExists = False Then
    att.SaveAsFile (outputDir + outputFile + "." + LCase(fileExtension))
    AttTotal = AttTotal + 1
    End If
    Next
    End If
    Next

    'Clean up
    Set Sel = Nothing
    Set Exp = Nothing
    Set App = Nothing
    Set fso = Nothing

    'Let user know we are done
    Dim doneMsg As String
    doneMsg = "Completed saving " + Format$(AttTotal, "#,0") + " attachments in " + Format$(MsgTotal, "#,0") + " Messages."
    MsgBox doneMsg, vbOKOnly, "Save Attachments"

    Exit Sub

    ErrorHandler:
    Dim errMsg As String
    errMsg = "An error has occurred. Error " + Err.Number + " " + Err.Description

    Dim errResult As VbMsgBoxResult
    errResult = MsgBox(errMsg, vbAbortRetryIgnore, "Error in Save Attachments")

    Select Case errResult
    Case vbAbort
    Exit Sub

    Case vbRetry
    Resume

    Case vbIgnore
    Resume Next
    End Select

    End Sub

    'Found this code in a google groups thread here:
    'http://groups.google.com/group/microsoft.public.scripting.vbscript/browse_thread/thread/7187886c3c83a570/c278a2753e9e7ceb%23c278a2753e9e7ceb
    'or http://shrinkster.com/l0v
    Public Function GetOutputDirectory() As String

    Dim retval As String 'Return Value

    Dim sMsg As String
    Dim cBits As Integer
    Dim xRoot As Integer

    Dim oShell As Object
    Set oShell = CreateObject("shell.application")
    sMsg = "Select Output Folder for Attachments"
    cBits = 1
    xRoot = 17

    On Error Resume Next
    Dim oBFF
    Set oBFF = oShell.BrowseForFolder(0, sMsg, cBits, xRoot)
    If Err Then
    Err.Clear
    GetOutputDirectory = ""
    Exit Function
    End If
    On Error GoTo 0

    If Not IsObject(oBFF) Then
    GetOutputDirectory = ""
    Exit Function
    End If

    If Not (LCase(Left(Trim(TypeName(oBFF)), 6)) = "folder") Then
    retval = ""
    Else
    retval = oBFF.self.Path

    'Make sure there's a \ on the end
    If Right(retval, 1) “\” Then
    retval = retval + “\”
    End If
    End If

    GetOutputDirectory = retval

    End Function

    ========

    Reply

Leave a reply to Dave Cancel reply