Save All Attachemnts In A Folder In Outlook

Tommy | CodeBits
September 09, 2010 07:00

Here is macro code for outlook to save all attachments of all selected email. It will prompt for a save directory and allow renaming of duplicate files. This just saved me probably a full day at work of saving all files since Outlook does not have this feature built in. Special thanks to Arcane Code

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

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

Screen Shot Of The Day

Tommy | General
August 26, 2010 08:30

Randomly got this on the new Digg page. Hilarious!

Fixing Themes

Tommy | General
February 23, 2010 21:00

Let me start off by apologizing for the older themes. I'm still new to CSS and web design.  I had put a little bit of code at the top of all the old CSS files to reset margins and padding on all the elements.  After research, I've determind that was a bad idea.  I've removed it from all the themes and made adjustments to a few classes to keep layout the same. I did only a quick spot check though, so I may have missed something.

 

If you have an old theme, I strongly recommend you update it.  Or if you notice anything really wierd, let me know and I will be glad to help in my free time.

Thanks

Theme Updates Feb 2010

Tommy | Themes
February 11, 2010 18:00

Good news everybody, I'm releasing a modified version of an older theme.  It has a little bit of CSS3 in it, but nothing to serious.  It will still look fine on Internet Explorer if you're unfortunate enough to still be running it.  I did however move some things around and changed up the comment layout for this one.  There is also a special surprise for administators!

 

Preview | Download

Royco Cup of Soup

Tommy | Videos
February 07, 2010 11:00

Nothing can explain this video, I think.

BlogEngine Update

Tommy | General
February 03, 2010 07:45

Blog Engine was updated to v1.6 last night.  This morning I made the CSS changes and a few edits to all the themes.  All the downloads how now been updated to v1.6 and removed the 1.5 versions.

2010 Brings New Themes

Tommy | Themes
January 24, 2010 19:55

Hey everyone, it's a new year and that means it's time to crank out some more themes. I'm going to start categorizing these themes a little better. Eventually I still want to do more with this site, but this is easier since I'm doing it partially for work anyways. Enjoy!

 

Preview | Download

Last Theme of 2009

Tommy | Themes
December 06, 2009 19:06

Hey everyone.  In keep with my random release schedule, here is another theme.  I tried to keep this one to a more minimal look. Again, I'm bad at naming these things. So I just called it SimpleGrey. It's modified/ported from themeforest.com link

 

Preview | Download

It's Business Time

Tommy | Themes
October 27, 2009 20:00

Second post in October! Amazing!  Actually I was going over some CSS and tossed together a new greenish theme. It's some odd coloring, but I like it.

Business Time

Last Windows XP Themes

Tommy | XP Themes
October 18, 2009 14:49

So I found out that there was 2 other XP Themes that I did not know about.  These are offical ones that replace the default Luna theme. Hopefully Windows 7 will have some cooler looking ones eventually.

Embedded.exe (500 KB)

RoyaleNoir.Rar (232 KB)

About

Mooglegiant.net is a site maintained by me (mooglegiant).  I occasionally put together blogengine.net themes, and random posts about tech/geek things.  If you like the site, or my work, don't forget to support me.  I'm sure you know where to click.