Outlook template rule to sort mails among directories - vba

Question

I have folders created for different projects (e.g. Proj1, Proj2, Proj3, ...).
It is general convention in the department to sent emails concerning specific project with its name in the subject (e.g. "Proj1: project finished!").
I know that I can create rules for every project to move mails that contain its name to the project folder. However, I would need to create as many rules as the number of folders I have - so its not very convenient and optimal.
Is there any way to create a rule (a single rule) (possibly, with VBA code) that will contain list of all folder names, search for any name from the list among mails' subjucts and automatically move mail to the corresponding folder?

Answer 1

In order to achieve exactly what you want you can use this macro:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
If m.Subject Like "*" & fldr.Name & "*" Then m.Move fldr
Next
Set fldr = Nothing
End Sub
This macro can be triggered by arrival of a new email if you add to ThisOutlookSession module these lines:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim o As Object
Set o = Application.Session.GetItemFromID(EntryIDCollection)
If TypeName(o) = "MailItem" Then RulesForFolders o
Set o = Nothing
End Sub
Though, I would recommend you get rid of the folders where you move your messages to. Instead, you can use keep all you messages in Inbox and use Search folders to group them in whatever order you want. This way you can quickly search through all your inbox and sort it as well as separate search folders. You can also have the same message in different folders not duplicating it. If you decide to do so, your macro will need to assign categories instead of moving messages:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder, str As Outlook.Store
For Each str In Application.Session.Stores
For Each fldr In str.GetSearchFolders
If m.Subject Like "*" & fldr.Name & "*" Then
m.Categories = m.Categories & "," & fldr.Name
m.Save
End If
Next
Next
Set fldr = Nothing
Set str = Nothing
End Sub

Answer 2

I needed the rule to process subfolders, so I have slightly modified the previous answer of #Vladislav Andreev:
Sub RulesForFolders(m As MailItem)
Dim fldr As Outlook.Folder
For Each fldr In GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders
If LCase(m.Subject) Like "*" & LCase(fldr.Name) & "*" Then
m.Move fldr
Exit For
End If
For Each subFldr In fldr.Folders
If LCase(m.Subject) Like "*" & LCase(subFldr.Name) & "*" Then
m.Move subFldr
Exit For
End If
Next
Next
Set fldr = Nothing
Set subFldr = Nothing
End Sub