Search for folder by key in subject then move new message to related folder

Not open for further replies.


New Member
Outlook version
Outlook 2016 64 bit
Email Account
I need to move the incoming message to the related folder if there is a loop for that 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.

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
If you have many folders, it will be slow... better is to use a double array - one for the keyword and one for the matching folder. The exception is if the keyword is the folder name...

i used this in a macro to file into a folder whose name was the keyword

Public Sub MoveMessages(ByVal Item As MailItem)
' get the string
' code goes here

' if the code is in the message, find the folder
' move message
    On Error Resume Next
    Item.UnRead = True
    Item.Move m_Folder
      If m_Folder Is Nothing Then
        Exit Sub
      End If

End Sub

' Borrowing Michael's code from

Public Sub FindFolder()
  Dim Name$
  Dim Folders As Outlook.Folders
  Dim Folder As Outlook.MAPIFolder

  Set m_Folder = Nothing
  m_Find = ""

  Name = "*" & strCode
  If Len(Trim$(Name)) = 0 Then Exit Sub
  m_Find = Name

  m_Find = LCase$(m_Find)

  Set Folder = Session.GetDefaultFolder(olFolderInbox)
  LoopFolders Folder.Folders

End Sub

Private Sub LoopFolders(Folders As Outlook.Folders)
  Dim Folder As Outlook.MAPIFolder
  Dim F As Outlook.MAPIFolder
  Dim Found As Boolean
  If SpeedUp = False Then DoEvents

  For Each F In Folders
      Found = (LCase$(F.Name) Like m_Find)

    If Found Then
      Set m_Folder = F
      Exit For
      LoopFolders F.Folders
      If Not m_Folder Is Nothing Then Exit For
    End If
End Sub
Not open for further replies.