Submitted By: Anonymous Submission

Saves all the attachments in an Outlook message, then updates the message with the location of the saved attachment. Designed to run as a macro within Outlook.

Visual Basic
Sub saveattach()

Const NO_OPTIONS = 0

Set FS = CreateObject("Scripting.FilesystemObject")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
    (WINDOW_HANDLE, "Select a folder:", NO_OPTIONS, "%USERPROFILE")
On Error GoTo ErrorHandler  
' Checks to see if user cancels the browse box without selecting a location
Set objFolderItem = objFolder.Self
On Error GoTo 0  ' Reset the error handler

objPath = objFolderItem.Path & "\"

Dim Msg, Style, Help, Ctxt, Response, MyString, Title, Default, MyValue, MyBody, FileToSave, _

Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector.CurrentItem
Set myAttachments = myItem.Attachments ' Grab all attachments in the message

Counter = myItem.Attachments.Count ' This defines the number of attachments in the message

Do While Counter > 0
   FileToSave = objPath & myAttachments.Item(Counter).DisplayName
   If FS.FileExists(FileToSave) Then ' Check to see if file already exists
      Msg = myAttachments.Item(Counter).DisplayName & " already exists.  Do you want to overwrite?"    
      ' Define message.
      Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define yes/no buttons to display
      Title = "Duplicate file"    ' Define title of message box
      Response = MsgBox(Msg, Style, Title, Help, Ctxt)
      If Response = vbNo Then    ' User chose No, so don't overwrite the file
         MsgBox "File NOT Saved"
         GoTo SkipFile
      End If
   End If
   myAttachments.Item(Counter).SaveAsFile FileToSave
   ' Update the body of the message with the path and filename of the saved file
   myItem.HTMLBody = myItem.HTMLBody & "    *** ATTACHMENT SAVED AS: " & FileToSave & Chr(13)
   MsgBox myAttachments.Item(Counter).DisplayName & " has been saved"  ' Feedback to the user!
   myAttachments.Remove Counter ' Delete the file from the message
   Counter = Counter - 1

Exit Sub
   Select Case Err.Number
      Case 91 ' Error #91 indicates that the user did not select a file path.  Cancel the script
         Exit Sub
      Case Else
         MsgBox Err.Number
   End Select

End Sub