Run VBA script on email matching Outlook Rule

[AshleyStraw]

Hello,

Using scripts posted online, I have put together the code below which move a selected email from the inbox to a subfolder.
I have tied this script to a rule
""
Apply this rule after the message arrives
with Subject of Interest in the subject
and on this machine only
run Project1.RuleMoveToFolder
""

How can I edit the code below to run on the emails selected by the rule above instead of the email currently selected in the inbox? I have tried including an if statement to check the subject of the email before moving it to the folder but it didn't work (email with the correct subject is not moved to the folder).

Here is the code:


Sub RuleMoveToFolder(item As MailItem)


mailboxNameString = "Mailbox - First Name Last Name"


Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olCurrExplorer As Outlook.Explorer
Dim olCurrSelection As Outlook.Selection


Dim olDestFolder As Outlook.MAPIFolder
Dim m As Integer


Set olNameSpace = olApp.GetNamespace("MAPI")
Set olCurrExplorer = olApp.ActiveExplorer
Set olCurrSelection = olCurrExplorer.Selection


Set olDestFolder = olNameSpace.Folders(mailboxNameString).Folders("Inbox").Folders("Folder1").Folders("Subfolder1")


For m = 1 To olCurrSelection.Count
Set item = olCurrSelection.item(m)

If InStr(0, item.Subject, "Subject of Interest", vbTextCompare) > 0 Then
item.Move olDestFolder
End

Next m


End Sub



Could you please point me in the right direction to apply this code only to emails that get selected by the rule?

Thank you very much.

[gmayor]

Rules run on messages as they arrive in the inbox. You don't need a script to move messages to named folders as this is a basic function provided by the rules.

If you want to use a macro to process an existing folder then you need a different approach:


Sub MoveMessages()
Dim olFolder As Folder
Dim olDestFolder As Folder
Dim olItems As Outlook.Items
Dim strFind As String
Dim i As Long, j As Long: j = 0
strFind = InputBox("Find what text?")
If strFind = "" Then GoTo lbl_Exit
Set olFolder = Application.Session.PickFolder
Set olDestFolder = Application.Session.GetDefaultFolder(olFolderInbox).folders("Test").folders("Test A")
Set olItems = olFolder.Items
For i = olItems.Count To 1 Step -1
If TypeName(olItems(i)) = "MailItem" Then
If InStr(1, olItems(i).Subject, strFind) > 0 Then
olItems(i).Move olDestFolder
j = j + 1
End If
End If
Next i
MsgBox j & " message items moved"
lbl_Exit:
Set olItems = Nothing
Set olFolder = Nothing
Set olDestFolder = Nothing
Exit Sub
End Sub

[AshleyStraw]

Thank you for your reply.

Indeed I can move an email to the folder using rules but there is more processing I need to do with that email once it's moved to the folder which is why I started the macro with moving it to the folder and then I need to write the code for the rest of the process.

It's the first time I write an Outlook macro: I understand that for the macro to run automatically on outlook I need to use the rule and the script must have the (item As MailItem) parameters in order to be linked to a rule. How would your code below run automatically in outlook since there are no input parameters to your procedure? I would only be to run it manually.

Thank you very much.

[gmayor]

The idea is that you either manually run a macro on a selection of items as above or you run it on a single item as in the code I posted in the thread http://www.vbaexpress.com/forum/showthread.php?62114-Pulling-Specified-Attachments-VBA e.g.


Public Sub ProcessMessage(Item As Outlook.MailItem)
'do stuff with Item
End Sub

This type of code can be run from a rule to perform a task on the current message (Item)

[dababler]

I've been trying to figure out a similar issue and I'm so so thankful to the OP for getting this topic started. Thank you!
But, I'm dumb, and I have questions.

I tried this code, and I'm not sure exactly what I'm doing wrong here.
I noticed the code below this obviously wouldn't work on my machine as I have different folders.


Set olFolder = Application.Session.PickFolder
Set olDestFolder = Application.Session.GetDefaultFolder(olFolderInbox).folders("Test").folders("Test A"

I changed that section of the code to match my folders.
22015
So I thought the code should look like this:

Sub MoveMessages()Dim olFolder As Folder
Dim olDestFolder As Folder
Dim olItems As Outlook.Items
Dim strFind As String
Dim i As Long, j As Long: j = 0
strFind = InputBox("Find what text?")
If strFind = "" Then GoTo lbl_Exit
Set olFolder = Application.Session.PickFolder
Set olDestFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Inbox").Folders("Test")
Set olItems = olFolder.Items
For i = olItems.Count To 1 Step -1
If TypeName(olItems(i)) = "MailItem" Then
If InStr(1, olItems(i).Subject, strFind) > 0 Then
olItems(i).Move olDestFolder
j = j + 1
End If
End If
Next i
MsgBox j & " message items moved"
lbl_Exit:
Set olItems = Nothing
Set olFolder = Nothing
Set olDestFolder = Nothing
Exit Sub
End Sub

However, that gave me an object not found exception.
So what am I doing wrong here, I'm very new to Outlook VBA and a novice (though I have put together a few of my own programs for Excel and Word) in general with VBA. :(

I even tried just using this:

Set olDestFolder = Application.Session.GetDefaultFolder(olFolderInbox)
That allowed me to actually bring up the search box but when I searched for "Emma" nothing moved.

Assuming I can get this figured out, is there a way to search message bodies for a series of string values?

Thanks!
:)

[gmayor]

As it is not clear how your folders and accounts are arranged who not simply pick the destination folder also


Set olFolder = Application.Session.PickFolder
Set olDestFolder = Application.Session.PickFolder

Or you can Loop throughout the stores and select the store name which is the partially obscured 'dbable' etc then loop through the folders there


Sub Test()
Dim olStore As Store
Dim olDestFolder As Folder
For Each olStore In Application.Session.Stores
If olStore.DisplayName = "dbable...etc" Then
For Each olDestFolder In olStore.GetRootFolder.folders
If olDestFolder.Name = "Test" Then
MsgBox olDestFolder.Items.Count
Exit For
End If
Next olDestFolder
Exit For
End If
Next olStore
End Sub

Or if you are certain of the path of 'Test' which appears to be a direct sub folder of 'dbable...etc' then you can select it directly


Sub Test2()
Dim olDestFolder As Folder
Set olDestFolder = Application.Session.Stores("dbable... etc").GetRootFolder.folders("Test")
MsgBox olDestFolder.Items.Count
End Sub

[dababler]

As it is not clear how your folders and accounts are arranged who not simply pick the destination folder also


Set olFolder = Application.Session.PickFolder
Set olDestFolder = Application.Session.PickFolder

Or you can Loop throughout the stores and select the store name which is the partially obscured 'dbable' etc then loop through the folders there


Sub Test()
Dim olStore As Store
Dim olDestFolder As Folder
For Each olStore In Application.Session.Stores
If olStore.DisplayName = "dbable...etc" Then
For Each olDestFolder In olStore.GetRootFolder.folders
If olDestFolder.Name = "Test" Then
MsgBox olDestFolder.Items.Count
Exit For
End If
Next olDestFolder
Exit For
End If
Next olStore
End Sub

Or if you are certain of the path of 'Test' which appears to be a direct sub folder of 'dbable...etc' then you can select it directly


Sub Test2()
Dim olDestFolder As Folder
Set olDestFolder = Application.Session.Stores("dbable... etc").GetRootFolder.folders("Test")
MsgBox olDestFolder.Items.Count
End Sub



All of those worked great thank you! :friends::bow::clap:



I do have another question if you don't mind.

I modified it to search through an Array; but I keep getting Run-Time error, the message you specified cannot be found.


Sub MoveMessages()Dim olFolder As Folder
Dim olDestFolder As Folder
Dim olItems As Outlook.Items
Dim t As Long, j As Long: j = 0
Dim arrTest As Variant
arrTest = Array("spring", "reaching out", "reviewing the data")


Set olFolder = Application.Session.Stores("dbable***x").GetRootFolder.Folders("Production")
Set olDestFolder = Application.Session.Stores("dbabler******").GetRootFolder.Folders("Test")
Set olItems = olFolder.Items
For t = olItems.Count To 1 Step -1
If TypeName(olItems(t)) = "MailItem" Then
For b = LBound(arrTest) To UBound(arrTest)
If InStr(olItems(t).Body, arrTest(b)) Then
olItems(t).Move olDestFolder
j = j + 1
Else

End If
Next b
End If
Next t
MsgBox j & " message items moved"
lbl_Exit:
Set olItems = Nothing
Set olFolder = Nothing
Set olDestFolder = Nothing
Exit Sub
End Sub








It will move a couple of messages then fail. What am I doing wrong?


Is it because I'm searching the body?
or is it because I am doing something wrong with my array...?
Here is a picture of my local window if that is helpful.

22031

Thank you again in advance for your help, and for your past help :)

[gmayor]

I have not tested but you probably need to step out of the loop when you move the message e.g.


For b = LBound(arrTest) To UBound(arrTest)
If InStr(olItems(t).Body, arrTest(b)) Then
olItems(t).Move olDestFolder
Exit For
j = j + 1
End If
Next b

[dababler]

I have not tested but you probably need to step out of the loop when you move the message e.g.


For b = LBound(arrTest) To UBound(arrTest)
If InStr(olItems(t).Body, arrTest(b)) Then
olItems(t).Move olDestFolder
Exit For
j = j + 1
End If
Next b


Thank you for the help when I saw your code it dawned on me what was going on, I had been staring it in frustration for so long I hadn't noticed I somehow had accidentally purged the "Next b" line from my code I was working on; which was of course causing the problem.

THANK YOU AGAIN SO MUCH!