Rule/Script Fail

[dodonohoe]

Hi all,

I have an Outlook rule which is not running in the correct order. Effectively it is running my VBA script before it is moving the email to the correct subfolder. When the rule runs it runs the script, which of course can't find the email as it hasn't been moved yet. It then moves the email into the correct folder. I had this working so have no idea why it would run the script first and then the other rules.

I have attached a screen grab.

Just wondering if anyone else has experienced this.

Thanks,

Des

[gmayor]

Why don't you use the script to move the message after you have processed it?

[dodonohoe]

Why don't you use the script to move the message after you have processed it?

Hi Graham,

The order of events is that the Microsoft rule is supposed to move the e-mail from arrival in my Inbox to a sub-folder called "MyFolder". The next step in the rule is that the script (Public Sub RunMacroItem As Outlook.MailItem) gets called and moves any attachments found in E-mails in "MyFolder".

What is actually happening is that for some reason the Script is running before the e-mail has arrived in the "MyFolder" subfolder.

So, when the new e-mail arrives, the rule runs, the script gets kicked off and can't find any e-mails in the "MyFolder" subfolder. Then the e-mail arrives in the subfolder.

Just as a note when I manually put an e-mail in the MyFolder subfolder and run the VBA it works perfectly.

I hope I have explained this properly.

Thanks,

Des

[gmayor]

A script that will run from a rule is associated with a message object
Sub MacroName(Item As Outlook.MailItem) . That message 'item' is the message that triggers the rule, so it shouldn't matter where the message is, the script should be able to process it.

[dodonohoe]

A script that will run from a rule is associated with a message object
Sub MacroName(Item As Outlook.MailItem) . That message 'item' is the message that triggers the rule, so it shouldn't matter where the message is, the script should be able to process it.


Hi Graham,

That is very useful to know. So are you saying that I should be able to run the script against the email as it sits in the inbox before it gets moved to the "MyFolder" subfolder? If that is the case would I just change the "MyFolder" reference as below to "Inbox"?


Public Sub RunMacro(Item As Outlook.MailItem)


RunMacroX


End Sub


Sub RunMacroX()

'Change this
SaveEmailAttachmentsToFolderNew "MyFolder", "", "C:\Processed File"

'Change to this
SaveEmailAttachmentsToFolderNew "Inbox", "", "C:\Processed File"



End Sub




Thanks,

Des

[gmayor]

No. What I meant is that you can process Item in the script. Look at how it is used in the thread - http://www.vbaexpress.com/forum/showthread.php?56578-Save-attachment-using-TAG-in-the-name in the script
Private Sub SaveAttachments(olItem As MailItem)That code is to save a specific type of attachment named from text in the file, but the principles are the same as what you appear to be attempting.

[dodonohoe]

No. What I meant is that you can process Item in the script. Look at how it is used in the thread - http://www.vbaexpress.com/forum/showthread.php?56578-Save-attachment-using-TAG-in-the-name in the script
Private Sub SaveAttachments(olItem As MailItem)That code is to save a specific type of attachment named from text in the file, but the principles are the same as what you appear to be attempting.


Hi Graham,

Before I take on the challenge of amending the method in the link you provide (thank you for that), do you know of any reason why the Outlook rule is not executing in the order that it is set up to. I even put a pause in the VBA piece to delay it to allow for the email to be moved into the subfolder. All that did was delay the running of the VBA, after that the emails are delivered.

Its very frustrating as the solution I have works perfectly.

Cheers,

Des

[dodonohoe]

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

Private Sub Application_NewMail()
Call Your_main_macro
End Sub

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

[gmayor]

As I have already said, if you are running the script from a rule the only message that matters to the script is the message that triggers the rule. If you want to save the attachments to that message then you can do so by referring to the message (item), and it doesn't matter whether the rule moves the message before running the script or after. It's the same 'item'.

Your code seems preccupied with processing folders, when it should be concentrating on processing the message. The following script run from a rule will save the attachments to that message in the named folder, which it will create if it doesn't exist and the filenames will be unique, no matter how many times the message is processed. You can run the TestProcess macro to test with a selected message.


Option Explicit

Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim sFileType As String
Dim j As Long
Const strSaveFldr As String = "C:\Path\Attachments\" 'The folder to save the attachments
CreateFolders strSaveFldr
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
sFileType = LCase(Right(olAttach.FileName, 4))
Select Case sFileType
' Add additional file types below
Case ".csv", ".xls", "xlsx", ".pdf"
strFname = olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
'olAttach.Delete 'delete the attachment
Case Else
End Select
Next j
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Sub TestProcess()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

[dodonohoe]

Hi Graham,

Your method works perfectly the 1st time I run the rule. Each subsequent time I send another email through it puts the attachments through to the subfolder but the attachments are not being saved out to the directory. I have put a message box at the start and end so I know the macro is being called.

Was this working for you when you sent a number of emails through.

Here is how I am using your full code.


Option Explicit
Public Sub Graham(item As Outlook.MailItem)


MsgBox "Macro started"


TestProcess


MsgBox "Macro ended"


End Sub





Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim sFileType As String
Dim j As Long
'Const strSaveFldr As String = "C:\Path\Attachments\" 'The folder to save the attachments
Const strSaveFldr As String = "C:\Trade File\" 'The folder to save the attachments

CreateFolders strSaveFldr
On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For j = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(j)
sFileType = LCase(Right(olAttach.FileName, 4))
Select Case sFileType
' Add additional file types below
Case ".csv", ".xls", "xlsx", ".pdf"
strFname = olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
'olAttach.Delete 'delete the attachment
Case Else
End Select
Next j
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Sub TestProcess()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

[gmayor]

The rule is intended to run on the message as it arrives. It is not intended to process a folder, and the addition you made to test it will not work either. The test macro I posted processes a single selected message. If you want to process a folder full of messages then use the following macro to call the process for each message in the selected folder. It doesn't run from a rule!:

Note that the macro employs a progress indicator. You can download that progress indicator userform (attached), extract from the zip and import it into your VBA editor. It will crash without the indicator present.


Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Outlook.MailItem
Dim ofrm As New frmProgress
Dim PortionDone As Double
Dim i As Long

On Error GoTo err_Handler
Set olNS = GetNamespace("MAPI")
Set olMailFolder = olNS.PickFolder
Set olItems = olMailFolder.Items
ofrm.Show vbModeless
i = 0
For Each olMailItem In olItems
i = i + 1
PortionDone = i / olItems.Count
ofrm.lblProgress.Width = ofrm.fmeProgress.Width * PortionDone
SaveAttachments olMailItem
DoEvents
Next olMailItem
err_Handler:
Unload ofrm
Set ofrm = Nothing
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub

[dodonohoe]

So for anyone that might get some benefit here is what I ended up using. Using Graham Mayors code (thanks Graham), the macro below does the following.

Any e-mails (that have attachments) that come into my mail box will have the attachments (depending on type) copied into a directory based on the attachment name.

Here is the full code. The only thing I added was the current date to the start of the attachment name and an instring search of the attachment name.


Option Explicit

Sub SaveAttachments(olItem As MailItem)
'An Outlook macro by Graham Mayor
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim sFileType As String
Dim J As Long
Dim item_in_review As String
Dim strSaveFldr1 As String


On Error GoTo CleanUp
If olItem.Attachments.Count > 0 Then
For J = olItem.Attachments.Count To 1 Step -1
Set olAttach = olItem.Attachments(J)
sFileType = LCase(Right(olAttach.FileName, 4))
Select Case sFileType
' Add additional file types below
Case ".csv", ".xls", "xlsx", ".pdf", ".txt"
strFname = olAttach.FileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))


'JP Morgan Cash transactions
item_in_review = strFname
If InStr(item_in_review, "Posted.csv") Then

strSaveFldr1 = "J:\General\Reports\Transactions A\"



Else

End If





'JP Morgan Cash Balances
item_in_review = strFname
If InStr(item_in_review, "Posted Statement") Then

strSaveFldr1 = "J:\General\Reports\Transactions B\"

Else

End If



'JP Morgan Positions
item_in_review = strFname
If InStr(item_in_review, "Priced.pdf") Then

strSaveFldr1 = "J:\General\Reports\Transactions C\"

Else

End If


strFname = FileNameUnique(strSaveFldr1, strFname, strExt)




Dim dateFormat As String


dateFormat = Format(now, "yyyy-mm-dd H-mm")



'olAttach.SaveAsFile strSaveFldr1 & strFname

'extended to include the date

olAttach.SaveAsFile strSaveFldr1 & dateFormat & " " & strFname



'olAttach.Delete 'delete the attachment
Case Else
End Select
Next J
olItem.Save
End If
CleanUp:
Set olAttach = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Sub TestProcess()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

[Romulo Avila]

Good evening, I found interesting this macro created by Graham and also the implementations performed by Dodonohoe, put on my outlook and macro did not run when it came email. How should I proceed to the macro to run without having to create a rule in Outlook. The macro should be placed in a module or in Outlook session?

[gmayor]

The macro is intended to be run from a rule. It will only then run automatically when the message arrives.
The alternative is to run it manually running one or other of the macros TestProcess or ProcessFolder featured elsewhere in the thread.

[dodonohoe]

Hi Romula,

Just in addition to Grahams comments. The code needs to be put into "ThisOutlookSession". Also when you are pointing the script in the rule at the code you will select "Sub SaveAttachments(olItem As MailItem)"

I am marking this thread as solved

Thanks

[gmayor]

The code needs to be put into "ThisOutlookSession"
ThanksThat's not necessary. The script can be attached to a rule from any Outlook module in the project.

[Romulo Avila]

Good Morning,
Thank you Graham and Des for help, thanks ..

[johnsm1]

hi - anyone please tell me where this code is failing:

I want to scrape the numbers from daily email i receive, the numbers are in the same position each time, the list might be 800 rows long so i want it to start at the top and repeat to the end until the list has finished.

i am 99% there, when i run the script it adds a single entry to the database table, but it is blank
If it helps further the actual string from the email body is below:
Y,F,AWB,111,11223344,1,MARKCUST1,20160706
Y,F,AWB,111,22334455,4,MARKCUST2,20160616
N,F,AWB,222,33445566,4,MARKCUST3,20160629
Y,M,AWB,333,44556677,3,MARKCUST4,20160625
etc (there could be 800 lines)

The only parts of this string i need is the 3 digit number after 'AWB,'......so 111, 111, 222, 333 etc
Note - AWB, will always be in that position (i.e 5th character in)
and the 8 digit number after that... so 11223344, 22334455 etc..



Sub ImportOutlookEmail()
Dim db As Database
Dim rst As Recordset
Dim ol As Outlook.Application
'Set ol = CreateObject("Outlook.Application")
Dim olInbox As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olObj As Object
Dim BodyTxt As String
Dim BodyRow As String
Set OlApp = CreateObject("Outlook.Application")
Set olInbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Folders("TDI") 'i have created a sub-folder in my inbox called "TDI", and it will only hold the emails i need to scrape, rather than search my whole inbox
Set olItems = olInbox.Items
Set db = CurrentDb
Set rst = CurrentDb.OpenRecordset("Email")
'NOTE: i have set up a table in access called "Email" with a memo field called "EmailData"
For Each olObj In olItems
If InStr(olObj.Subject, " ") > 0 Then 'the subject line is always going to be blank, but only these email will be in the folder "TDI"
'BodyTxt = Email.Body '***this gives me an error Runtime 424 Object Required, when i cut it out it gives me a blank entry in the table

BodyTxt = Mid(BodyTxt, InStr(BodyTxt, "AWB,") + 5, 8))
'this should search the body for the word "AWB" then cuts from character 5 onwards, then moves to the next line and repeats until rows end

Do
rst.AddNew
rst!EmailData = BodyRow
rst.Update
If BodyTxt = "" Then Exit Do
Loop
End If 'i added End If because it kept showing an error that i have an "IF but not an EndIf", have i added in the correct place?


Next


rst.Close


Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set TempRst = Nothing


End Sub

thanks in advance