#1
|
|||
|
|||
Save attachments to defined path via VBA
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 |
#2
|
|||
|
|||
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. |
#3
|
|||
|
|||
Great module, but not showing in the Select Scripts dialogue box
Any help appreciated to resolve. |
#4
|
|||
|
|||
Save e-mail attachments
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 |
#5
|
|||
|
|||
Did you try to run this from the Developer Macro or as an automation when the email comes in?
|
#6
|
|||
|
|||
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? |
#7
|
|||
|
|||
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? |
#8
|
|||
|
|||
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 |