Search for folder by key in subject - vba

Question

I need to move the incoming message to the related folder depending on a key in the subject of the message.
I developed a script for getting the key in the subject of new message. How can I search rest of messages by a key and retrieve related folder?
Sub CustomMailMessageRule(Item As Outlook.MailItem)
Dim strTicket, strSubject As String
Dim strFolder As String
strTicket = "None"
strSubject = Item.Subject
If InStr(1, strSubject, "#-") > 0 Then
strSubject = Mid(strSubject, InStr(strSubject, "#-") + 2)
If InStr(strSubject, " ") > 0 Then
strTicket = Left(strSubject, InStr(strSubject, " ") - 1)
End If
End If
the unknown part, search all folders by key and retrieve the related folder
strFolder = "???"
and finally, move the incoming message to the related folder by below code
If InStr(strFolder) > 0 Then
Item.Move Session.GetDefaultFolder(olFolderInbox).folders(strFolder)
MsgBox "Your New Message has been moved to related folder "
End Sub
I'm new in VBA.

Answer 1

This searches folders recursively for an item by subject.
Option Explicit
Sub CustomMailMessageRule(Item As mailItem)
Dim strSubject As String
Dim strDynamic As String
Dim strFilter As String
Dim originFolder As Folder
Dim startFolder As Folder
Dim uPrompt As String
strSubject = Item.subject
Set startFolder = Session.GetDefaultFolder(olFolderInbox)
' To reference any inbox not specifically the default inbox
'Set startFolder = Session.folders("email address").folders("Inbox")
Set originFolder = startFolder
' For testing the mail subject is "This is a test"
If InStr(1, strSubject, "This is") > 0 Then
' For testing the dynamically determined key is "a test"
strDynamic = "a test"
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " LIKE '%" & strDynamic & "%'"
Debug.Print strFilter
' Advanced search requires "Scope" to be specified so it appears
' not easy/possible to process every subfolder in the way described here
' https://stackoverflow.com/questions/43638711/outlook-macro-advanced-search
' This recursively processes every subfolder
processFolder originFolder, startFolder, strFilter, Item
uPrompt = "Mail with " & strDynamic & " in subject not found in subfolders of " & startFolder.Name
Debug.Print uPrompt
MsgBox uPrompt
End If
ExitRoutine:
Set startFolder = Nothing
End Sub
Private Sub processFolder(ByVal originFolder As Folder, ByVal oParent As Folder, strFilter As String, oIncomingMail As mailItem)
Dim oFolder As Folder
Dim oObj As Object
Dim filteredItems As items
Dim uResp As VbMsgBoxResult
Debug.Print oParent
If originFolder.EntryID <> oParent.EntryID Then
' This narrows the search.
' https://stackoverflow.com/questions/21549938/vba-search-in-outlook
Set filteredItems = oParent.items.Restrict(strFilter)
If filteredItems.count > 0 Then
Debug.Print oParent
Debug.Print "Mail found in " & oParent.Name
uResp = MsgBox(Prompt:="Move Message to folder: " & oParent.Name & "?", _
Buttons:=vbYesNoCancel)
If uResp = vbYes Then
oIncomingMail.move oParent
End
End If
If uResp = vbCancel Then End
End If
End If
If (oParent.folders.count > 0) Then
For Each oFolder In oParent.folders
processFolder originFolder, oFolder, strFilter, oIncomingMail
Next
End If
End Sub