Run VBA script on email matching Outlook Rule

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:

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.

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:

Code:

---

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

---

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.

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/show...ttachments-VBA e.g.

Code:

---

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)

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.

Code:

---

    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.
Attachment 22015
So I thought the code should look like this:

Code:

---

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:

Code:

---

  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!
:)

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

Code:

---

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

Code:

---

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

Code:

---

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

---

Quote:

---

Originally Posted by gmayor

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

Code:

---

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

Code:

---

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

Code:

---

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.

Code:

---

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.

Attachment 22031

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

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

Code:

---

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

---

Quote:

---

Originally Posted by gmayor

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

Code:

---

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!