Save attachments to defined path via VBA

eltonlaw · #1 07-26-2012, 08:50 PM

Dear Expert,
Needs to save a lot of attachments in a day to different folders in different drives in a day.
Need to switch and switch which takes time.

Just wonder can VBA define a specified path to save the attachments?
I can use 4 different macros with different paths to solve all the issues.

Hope dear expert can help.

Best regards,
Elton

niton · #2 03-14-2013, 09:10 PM

Try this

Code:

 
Private Sub SaveAttachments_Selection()
Dim Item As Object
Dim ItemAttachment As Object
Dim StrFolderPath As String
Dim strFileName As String
Dim ItemsCount As Long
Dim ItemsAttachmentsCount As Long
Dim iSave As Long
Dim msg As String
StrFolderPath = "C:\test\"
If (Dir$(StrFolderPath, vbDirectory) = "") Then
    MsgBox "'" & StrFolderPath & "' not exist"
    MkDir StrFolderPath
    MsgBox "'" & StrFolderPath & "' we create it"
Else
    MsgBox "'" & StrFolderPath & "' exist"
End If
If Right(StrFolderPath, 1) <> "\" Then
   StrFolderPath = StrFolderPath & "\"
End If
ItemsCount = 0
ItemsAttachmentsCount = 0
 
For iSave = 1 To ActiveExplorer.Selection.Count
 
    Set Item = ActiveExplorer.Selection(iSave)
 
    If TypeOf Item Is MailItem Or TypeOf Item Is PostItem Then
        ItemsCount = ItemsCount + 1
        For Each ItemAttachment In Item.Attachments
            ItemsAttachmentsCount = ItemsAttachmentsCount + 1
            ' Get the file name.
            strFileName = ItemAttachment.FileName
            ' Combine with the path to the Attachments folder.
            strFileName = StrFolderPath & ItemsAttachmentsCount & "_" & strFileName
            ' Save the attachment as a file.
            ItemAttachment.SaveAsFile strFileName
        Next ItemAttachment
 
    End If
 
Next
ExitSub:
Set Item = Nothing
msg = "All Selected Folder Attachments Have Been Downloaded ..." & vbCr & vbCr
msg = msg & "ItemsCount : " & ItemsCount & vbCr & vbCr
msg = msg & "ItemsAttachmentsCount : " & ItemsAttachmentsCount
MsgBox msg
End Sub

******************
Consider rating the thread by going to the "Rate Thread" dropdown.

Bravo33 · #3 01-27-2014, 04:27 AM

Great module, but not showing in the Select Scripts dialogue box

Any help appreciated to resolve.

Danny Rodrigues · #4 01-27-2014, 09:49 AM

Dear all,

I have the same problem. I need to save some attachments (each one has a different name (*.xml)) in some folders (according to the sender).

Anyone can help us? I've tried the code above but didn't work.

Best regards,

Danny Rodrigues

Bravo33 · #5 01-27-2014, 09:59 AM

Quote:

Originally Posted by Danny Rodrigues

Dear all,

I have the same problem. I need to save some attachments (each one has a different name (*.xml)) in some folders (according to the sender).

Anyone can help us? I've tried the code above but didn't work.

Best regards,

Danny Rodrigues

Did you try to run this from the Developer Macro or as an automation when the email comes in?

Danny Rodrigues · #6 01-27-2014, 10:36 AM

Hi Bravo.

My mistake, sorry. Worked. But I in this code I have to select the attachement and than run the code.
I am trying to run it automatically when the email comes in.

I am trying to do the following:

-Saved the code into Outlook VBA (alt+F11).
- Made a new rule that runs a script

But when the box to select a script appears the code's name didn't appears.

Could you help me?

Bravo33 · #7 01-27-2014, 11:50 AM

Outlook does not recognize the macro unless it is declared as a mail item.

Private Sub SaveAttachments_Selection()
Replace the () with this.
(itm As Outlook.MailItem)

The macro now shows in Outlook, but still does not copy the attachments to the file location I have named.

Anyone?

niton · #8 07-03-2014, 04:59 PM

The original code works on a selection of one or more mailitems in any folder.

To run as a script on mail being received try this:

Code:

 
Sub SaveAttachments_ReceivedMail(item As mailItem)
Dim ItemAttachment As Object
Dim StrFolderPath As String
Dim strFileName As String
Dim ItemsAttachmentsCount As Long
Dim iSave As Long
Dim msg As String
StrFolderPath = "C:\test\"
If (Dir$(StrFolderPath, vbDirectory) = "") Then
    Debug.Print "'" & StrFolderPath & "' not exist"
    MkDir StrFolderPath
    Debug.Print "'" & StrFolderPath & "' we create it"
Else
    Debug.Print "'" & StrFolderPath & "' exist"
End If
If Right(StrFolderPath, 1) <> "\" Then
   StrFolderPath = StrFolderPath & "\"
End If
ItemsAttachmentsCount = 0
 
    If TypeOf item Is mailItem Then
 
        For Each ItemAttachment In item.Attachments
            ItemsAttachmentsCount = ItemsAttachmentsCount + 1
            ' Get the file name.
            strFileName = ItemAttachment.FileName
            ' Combine with the path to the Attachments folder.
            strFileName = StrFolderPath & ItemsAttachmentsCount & "_" & strFileName
            ' Save the attachment as a file.
            ItemAttachment.SaveAsFile strFileName
        Next ItemAttachment
 
    End If
 
ExitSub:
Set item = Nothing
msg = "All Selected Folder Attachments Have Been Saved to " & StrFolderPath & vbCr & vbCr
msg = msg & "ItemsAttachmentsCount : " & ItemsAttachmentsCount
Debug.Print msg
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
FileSystemObject Compile Error: User-Defined Type Not Defined	gsrikanth	Excel Programming	2	03-28-2022 06:32 AM
Range.Information(wdStartOfRangeRowNumber): Application-defined or Object-defined err	tinfanide	Excel Programming	2	06-09-2012 10:19 AM
Application-defined or Object-defined error	Manit	Excel Programming	4	12-08-2011 07:35 PM
Outlook 2007 prompts to save opened attachments	OfficeAppentice	Outlook	0	11-03-2011 09:24 AM
code to save / rename / send attachments	unit213	Outlook	1	09-26-2007 08:15 PM