Revisting the Outlook Save All Attachments Macro

Back in 2007 I created a post on an Outlook Macro to save all attachments for an e-mail. Some people were having a problem downloading the file (not sure why as it worked for me) but to help out thought I’d repost the code in full.

Note I have not tried this with Outlook 2010, so use at your own risk.


Option Explicit


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 App As New Outlook.Application
  Dim Exp As Outlook.Explorer
  Dim Sel As Outlook.Selection
  
  Dim AttachmentCnt As Integer
  Dim AttTotal As Integer
  Dim MsgTotal As Integer
  
  Dim outputDir As String
  Dim outputFile As String
  Dim fileExists As Boolean
  Dim cnt As Integer
  
  'Requires reference to Microsoft Scripting Runtime (SCRRUN.DLL)
  Dim fso As FileSystemObject
    
  Set Exp = App.ActiveExplorer
  Set Sel = Exp.Selection
  Set fso = New FileSystemObject

  outputDir = GetOutputDirectory()
  If outputDir = "" Then
    MsgBox "You must pick an directory to save your files to. Exiting SaveAttachments.", vbCritical, "SaveAttachments"
    Exit Sub
  End If
    
  'Loop thru each selected item in the inbox
  For cnt = 1 To Sel.Count
    'If the e-mail 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)
        outputFile = att.fileName
        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 the file does not exist
        If fileExists = False Then
          att.SaveAsFile (outputDir + outputFile)
          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 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
    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



About these ads

6 Responses to “Revisting the Outlook Save All Attachments Macro”

  1. James Says:

    This is very useful – how would you change the macro to remove the attachments from the emails after you’ve saved them? (I don’t want to delete the emails from my inbox, just move the egregious attachments elsewhere)

    • sentryboy Says:

      Thank you so much for this code.
      I modified it for my needs around mailbox quota.
      I didn’t want to browse for the folder each time, so I set it up to save to a path of “SenderName\Subject\DateTime” under a root directory provided in the script. This required a little bit of work because file paths don’t like colons, slashes, or quotes in the path name, but these aren’t a problem for subject names and colons are always found in datetime fields.

      I wanted to remove the attachments, and I wanted to maintain a link between the file and the email.

      I also wanted to ensure that the emails continued to show up in my search results when I typed “hasattachments:yes” because this is just how I think, so I added a tiny attachment back in. To do this, I have to maintain a file on disk somewhere that I attach to each email.

      The code is pasted below because I find it so useful and because I so appreciate the massive kickstart you gave me through your code.

      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 App As New Outlook.Application
      Dim Exp As Outlook.Explorer
      Dim Sel As Outlook.Selection

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

      Dim EmptyAttachment As String
      Dim RootDirectory As String

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

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

      RootDirectory = “C:\Users\username\Documents\Mail Attachments”

      ‘Note that the EmptyAttachment file needs to exist. Just create a new text file and save it empty.

      EmptyAttachment = “C:\Temp\Empty Attachment.txt”

      ‘**************************************************************************************************
      ‘**************************************************************************************************

      Set Exp = App.ActiveExplorer
      Set Sel = Exp.Selection
      Set fso = New FileSystemObject

      ‘Loop thru each selected item in the inbox
      For cnt = 1 To Sel.Count

      ‘If the e-mail has attachments…
      If Sel.Item(cnt).Attachments.Count > 0 Then
      outputDir = GetOutputDirectory(RootDirectory, Sel.Item(cnt))

      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 = att.FileName
      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 the file does not exist
      If fileExists = False Then

      att.SaveAsFile (outputDir + outputFile)
      If Sel.Item(cnt).BodyFormat = olFormatHTML Or Sel.Item(cnt).BodyFormat = olFormatRichText Then
      Dim BodyStart As Integer

      ‘The following lines are for debugging, to allow inspection of the raw content of an HTML or Rich Text email
      ‘Content Before:
      ‘ Dim FileObject As File
      ‘ Dim Stream As TextStream
      ‘ Set Stream = fso.CreateTextFile(“c:\temp\test.txt”, True)
      ‘ Stream.Write (Sel.Item(cnt).HTMLBody)

      ‘Make the change to the body
      BodyStart = InStr(1, Sel.Item(cnt).HTMLBody, “”, “>Attachment Saved to ” + outputFile +

      “, BodyStart + 1, 1, vbTextCompare)

      ‘Content After
      ‘ Stream.Write (Sel.Item(cnt).HTMLBody)
      ‘ Stream.Close
      ‘ Sel.Item(cnt).Save
      End If

      If Sel.Item(cnt).BodyFormat = olFormatPlain Then
      Sel.Item(cnt).Body = “Attachment Saved to “”file:///” + outputDir + outputFile + “””” + vbCrLf + Sel.Item(cnt).Body
      End If

      AttTotal = AttTotal + 1

      End If

      Next ‘ Attachment

      ‘Remove all attachments
      While Sel.Item(cnt).Attachments.Count > 0
      Set att = Sel.Item(cnt).Attachments(1)
      att.Delete
      Wend

      If Sel.Item(cnt).Class = olMail Then
      Dim oItem As MailItem
      Set oItem = Sel.Item(cnt)
      oItem.Attachments.Add (EmptyAttachment)
      End If

      End If ‘ There are attachments

      Next ‘ Selected Item

      ‘Clean up
      Set Sel = Nothing
      Set Exp = Nothing
      Set App = Nothing
      Set fso = Nothing
      Set att = Nothing
      Set oItem = 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(RootDirectory As String, oItem As MailItem) As String

      ‘Code to prompt user to browse for folder has been commented out.
      ‘In exchange, the mail object is parsed, and the folder is created from SenderName/Subject/DateTime

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

      Dim oFSO As FileSystemObject
      Dim FolderName As String

      Set oFSO = New FileSystemObject

      FolderName = RootDirectory
      If Not oFSO.FolderExists(FolderName) Then
      oFSO.CreateFolder (FolderName)
      End If

      FolderName = FolderName + “\” + oItem.SenderName
      If Not oFSO.FolderExists(FolderName) Then
      oFSO.CreateFolder (FolderName)
      End If

      ‘Certain characters that are just fine in subject lines are problematic for filesystem folder names
      ‘Remove them
      ‘(I know there’s a better way to do this, but I’ll leave that for someone else to enhance)

      Dim Subject
      Subject = Replace(oItem.Subject, “RE:”, “”, 1, -1, vbTextCompare)
      Subject = Replace(Subject, “FW:”, “”, 1, -1, vbTextCompare)
      Subject = Replace(Subject, “.”, “”, 1, -1, vbTextCompare)
      Subject = Replace(Subject, “”””, “”, 1, -1, vbTextCompare)
      Subject = Replace(Subject, “:”, “”, 1, -1, vbTextCompare)
      Subject = Replace(Subject, “/”, “”, 1, -1, vbTextCompare)
      Subject = LTrim(RTrim(Subject))

      FolderName = FolderName + “\” + Subject
      If Not oFSO.FolderExists(FolderName) Then
      oFSO.CreateFolder (FolderName)
      End If

      ‘Remove colons and slashes in DateTime
      FolderName = FolderName + “\” + Replace(Replace(oItem.ReceivedTime, “/”, “-”, 1, -1, vbTextCompare), “:”, “.”, 1, -1, vbTextCompare)

      If Not oFSO.FolderExists(FolderName) Then
      oFSO.CreateFolder (FolderName)
      End If
      GetOutputDirectory = FolderName + “\”

      End Function

  2. Saving All Attachments in Outlook « Arcane Code Says:

    [...] UPDATE: Some users were having problems downloading the code, so I’ve posted it at: http://arcanecode.com/2011/07/16/revisting-the-outlook-save-all-attachments-macro/ [...]

  3. Saundra Says:

    This was incredibly helpful, thank you! Once I updated my reference to the scrrun.dll, it worked flawlessly for me.

  4. Outlook Save-Attachments macro | Mike's space Says:

    [...] all props and credit to ArcaneCode, I post here a fork of his save-attachments macro.  My needs were a bit different from [...]

  5. Craig Says:

    Thanks for the macro. I got tired of making my own name changes when there was a similarly named file already in the destination directory so I made a slight modification to the script that would automatically add a number to the end of the file name. This number will increment on each iteration of the loop as well.

    Here is the relevant part of the macro that I changed:

    ‘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 = att.FileName

    fileExists = fso.fileExists(outputDir + outputFile)

    Do While fileExists = True
    cntx = cntx + 1
    outputFile = outputFile + Str(cntx)
    ‘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

    Thanks for this. It is a BIG help.


Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Follow

Get every new post delivered to your Inbox.

Join 100 other followers

%d bloggers like this: