Thread: saving attachments automatically

hello, I have been scouring the internet to find a macro that will work in Outlook 2007 that will save all email attachments in a specific folder to a specific folder on my hard drive. right now I have a rule set to move all messages from a specific sender with an attachment to go to a folder called "Temp" in my Outlook personal folders. I want to then save all of the PDF files attached to those messages to "C:\Temp\". I have tried to adapt the macros below without success. Any help would be greatly appreciated as I get about 50 of these emails a day and need to save them individually!

This one fails to an error message stating: "The operation failed. An object could not be found". I suspect that becasue this code requires a reference to be set to the Microsoft Outlook 8.0 Object Model is why it is failing. But I really have no idea.

Code:

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro. This code requires a reference to be set
' to the Microsoft Outlook 8.0 Object Model
    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim appOl As New Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Item As Object
    Dim Atmt As Outlook.Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As Variant
    Set ns = appOl.GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Temp") ' Enter correct subfolder name.
    i = 0
' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Sales Reports folder.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "pdf" extension
            If Right(Atmt.FileName, 3) = "pdf" Then
            ' This path must exist! Change folder name as necessary.
                FileName = "C:\Ecosure audits\" & _
                    Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item
' Show summary message
   ' If i > 0 Then
     '   varResponse = MsgBox("I found " & i & " attached files." _
     '   & vbCrLf & "I have saved them into the C:\Email Attachments folder." _
     '   & vbCrLf & vbCrLf & "Would you like to view the files now?" _
     '   , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
      '  If varResponse = vbYes Then
      '      Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
     '   End If
   ' Else
      '  MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
  ' End If
' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Set appOl = Nothing
    Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: SaveAttachmentsToFolder" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

I found this one on VBAExpress.com and tried to adapt it but it did not work either.

Code:

'###############################################################################
 '### Module level Declarations
 'expose the items in the target folder to events
Option Explicit
Dim WithEvents TargetFolderItems As Items
 'set the string constant for the path to save attachments
Const FILE_PATH As String = "C:\Ecosure audits\"
 
 '###############################################################################
 '### this is the Application_Startup event code in the ThisOutlookSession module
Private Sub Application_Startup()
     'some startup code to set our "event-sensitive" items collection
    Dim ns As Outlook.NameSpace
     '
    Set ns = Application.GetNamespace("MAPI")
    Set TargetFolderItems = ns.Folders.Item( _
    "Personal Folders").Folders.Item("Temp").Items
     
End Sub
 
 '###############################################################################
 '### this is the ItemAdd event code
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
     'when a new item is added to our "watched folder" we can process it
    Dim olAtt As Attachment
    Dim i As Integer
     
    If Item.Attachments.Count > 0 Then
        For i = 1 To Item.Attachments.Count
            Set olAtt = Item.Attachments(i)
             'save the attachment
            olAtt.SaveAsFile FILE_PATH & olAtt.FileName
             
             'if its an Excel file, pass the filepath to the print routine
            If UCase(Right(olAtt.FileName, 3)) = "XLS" Then
                PrintAtt (FILE_PATH & olAtt.FileName)
            End If
        Next
    End If
     
    Set olAtt = Nothing
     
End Sub
 
 '###############################################################################
 '### this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()
     
    Dim ns As Outlook.NameSpace
    Set TargetFolderItems = Nothing
    Set ns = Nothing
     
End Sub
 
 '###############################################################################
 '### print routine
Sub PrintAtt(fFullPath As String)
     
    Dim xlApp As Excel.Application
    Dim wb As Excel.Workbook
     
     'in the background, create an instance of xl then open, print, quit
    Set xlApp = New Excel.Application
    Set wb = xlApp.Workbooks.Open(fFullPath)
    wb.PrintOut
    xlApp.Quit
     
     'tidy up
    Set wb = Nothing
    Set xlApp = Nothing
     
End Sub

Originally Posted by dcgrove

This one fails to an error message stating: "The operation failed. An object could not be found". I suspect that becasue this code requires a reference to be set to the Microsoft Outlook 8.0 Object Model is why it is failing. But I really have no idea.

Yes you will need to make a reference to your current version of Outlook - I am guessing that you should now be either 11.0 or 12.0

Code:

    Set SubFolder = Inbox.Folders("Temp") ' Enter correct subfolder name.

What did you change the TEMP here to.

The code otherwise looks fine.