So from a little bit of research over the weekend it seems that the following can be said of the Outlook rule. If you add a script to the rule, the script will run before the rule does. So in this instance I am going to have the Outlook rule move the target mail from my Inbox to the sub folder called "MyFolder" with no script involved. And that works perfectly well. The next step is to get the VBA macro to run seperately which will move the attachments from "MyFolder" to a directory. I have the macro code written and working below that will move the attachments from the e-mails in "MyFolder" But how do I call the macro? It seems to me that one option is to add an event listener. The trouble with the event listener is that it focuses on the Inbox if I use something like
PrivateSub Application_NewMail()
Call Your_main_macro
EndSub
So how do I get the following code to be called when a mail arrives in the "MyFolder" subfolder?
Public Sub GuinnessCashBalances(item As Outlook.MailItem)
RunMacroGuinnessCashBalances
End Sub
Sub RunMacroGuinnessCashBalances()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this " C:\Trade File " the folder must exist.
'here we are telling it what outlook folder to take the files from, what type of files , and where to put them on the network.
SaveEmailAttachmentsToFolderNew "MyFolder", "", "C:\Trade File"
End Sub
Sub SaveEmailAttachmentsToFolderNew(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim item As MailItem
Dim Atmt As Attachment
Dim FileName As String
Dim sFileType As String
Dim MyDocPath As String
Dim i As Integer, j As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
' 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
i = 0
' Check each message for attachments and extensions
For Each item In SubFolder.Items
If item.Attachments.Count > 0 Then
For j = item.Attachments.Count To 1 Step -1
Set Atmt = item.Attachments(j)
sFileType = LCase$(Right$(Atmt, 4))
Select Case sFileType
' Add additional file types below
Case ".csv", ".xls", "xlsx", ".pdf"
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
End Select
item.Attachments.Remove j
Next j
item.Close olSave
End If
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