Outlook 2010 - Save Attachment to Specific Folder on Disk Automatically

Question

I have the following code:

 

Sub Test()





Dim arg1 As String

Dim arg2 As String

Dim arg3 As String



arg1 = "Trekker"

arg2 = "XLS"

arg3 = "C:\Trekker"

'If you use "" it will create a date/time stamped

'folder for you in the "My Documents" folder.

'Note: If you use this "C:\Users\Ron\test" the folder must exist



SaveEmailAttachmentsToFolder arg1, arg2, arg3





End Sub







Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _

         ExtString As String, DestFolder As String)

 Dim ns As NameSpace

 Dim Inbox As MAPIFolder

 Dim SubFolder As MAPIFolder

 Dim Item As Object

 Dim Atmt As Attachment

 Dim FileName As String

 Dim MyDocPath As String

 Dim I As Integer

 Dim wsh As Object

 Dim fs As Object

 Dim createtime As String



 On Error GoTo ThisMacro_err



 Set ns = GetNamespace("MAPI")

 Set Inbox = ns.GetDefaultFolder(olFolderInbox)

 Set SubFolder = Inbox.Folders(OutlookFolderInInbox)



 I = 0

 ' Check subfolder for messages and exit of none found

 If SubFolder.Items.Count = 0 Then

  MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _

    vbInformation, "Nothing Found"

  Set SubFolder = Nothing

  Set Inbox = Nothing

  Set ns = Nothing

  Exit Sub

 End If



 'Create DestFolder if DestFolder = ""

 If DestFolder = "" Then

  Set wsh = CreateObject("WScript.Shell")

  Set fs = CreateObject("Scripting.FileSystemObject")

  MyDocPath = wsh.SpecialFolders.Item("mydocuments")

  DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")

  If Not fs.FolderExists(DestFolder) Then

   fs.CreateFolder DestFolder

  End If

 End If



 If Right(DestFolder, 1) <> "\" Then

  DestFolder = DestFolder & "\"

 End If



 ' Check each message for attachments and extensions

 For Each Item In SubFolder.Items

  For Each Atmt In Item.Attachments

   If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then

    createtime = Format(Item.CreationTime, "d-mmm-yy") & " " & Format(Item.CreationTime, "HhNnSs AM/PM")

    FileName = DestFolder & Item.SenderName & " " & createtime & " " & Atmt.FileName

    Atmt.SaveAsFile FileName

    I = I + 1

   End If

  Next Atmt

 Next Item



 ' Show this message when Finished

 If I > 0 Then

  MsgBox "You can find the files here : " _

    & DestFolder, vbInformation, "Finished!"

 Else

  MsgBox "No attached files in your mail.", vbInformation, "Finished!"

 End If



 ' Clear memory

ThisMacro_exit:

 Set SubFolder = Nothing

 Set Inbox = Nothing

 Set ns = Nothing

 Set fs = Nothing

 Set wsh = Nothing

 Exit Sub



 ' Error information

ThisMacro_err:

 MsgBox "An unexpected error has occurred." _

   & vbCrLf & "Please note and report the following information." _

   & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _

   & vbCrLf & "Error Number: " & Err.Number _

   & vbCrLf & "Error Description: " & Err.Description _

   , vbCritical, "Error!"

 Resume ThisMacro_exit



End Sub







It is created in outlook vba and I received it from http://www.rondebruin.nl/mail/folder2/saveatt.htm.

It runs correctly, but it is not done automatically. I have to hit alt + f11 and then run the macro. How can I convert this to a script and automatically run when the rule is initiated?

Thanks!

Answer 1

At which point do you want it to automatically run?

 

You need to create a handler for the event you want to trigger the method call.

 

Like say upon adding an attachment or sending the email.

Answer 2

Kit,

 

Thanks for replying!!!.  I need to this macro run when I have an email arrive in the "Trekker" folder under my inbox.  I am new to Outlook scripting and event handling. Can you please provide an example.

 

Thanks!!

---

ddd

Answer 3

Kit,

 

I found out how to do event handling.  I have the handler:

Private Sub Application_NewMail()
Call Test
End Sub

However, this fires everytime an item arrives in my inbox.  How may I alter this so it only fires when an item arrives in a particular subfolder?

 

Thanks again!

---

ddd

Answer 4

NewMail() and the more recent NewMailEx() do only run on additions to Inbox.

Get the subfolder as a Folder or MAPIFolder, then get a reference to that folder's Items collection and set up an event handler for the ItemAdd() event for that Items collection. That would do the trick.

---

Ken Slovak MVP - Outlook

Answer 5

Ken,

 

Thanks for your reply!

So this is what my thisoutlooksession looks like now:

 However, it still does not fire... Do I have to put something in the application_newmail routine? or am i doing this wrong?

Dim myOlApp As New Outlook.Application
Public WithEvents myOlItems As Outlook.Items

Public Sub Initialize_handler()
  Set myOlItems = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Trekker")
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
 Call Test
End Sub
    

Private Sub Application_NewMail()

End Sub

 

---

ddd

Answer 6

Unless you actually want to handle new items to Inbox you don't need NewMail() at all. If you want to handle that you are far better off with NewMailEx(), which doesn't miss items coming in as NewMail() does.

Are you calling the Initialize_handler() method to initialize things? Call it either manually or from the Application_Startup() event handler or from some other method.

---

Ken Slovak MVP - Outlook

Answer 7

Thanks!!! That worked perfect!! NewMail() stinks!!!

 

this is my code now:

 

Dim myOlApp As New Outlook.Application
Public WithEvents myOlItems As Outlook.Items

Public Sub Initialize_handler()
    Set myOlItems = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Trekker").Items
End Sub

Private Sub myOlItems_ItemAdd(ByVal Item As Object)
 Call KastleReports
End Sub

Private Sub Application_Startup()
Initialize_handler

End Sub

 

---

ddd

Answer 8

dbansal,

can you please write all the code?

THX

Fedemrpink

Answer 9

sorry!

---

ddd