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

[Erfan]

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]

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
    FindFolder
    On Error Resume Next
    Item.UnRead = True
    Item.Move m_Folder
      If m_Folder Is Nothing Then
        Exit Sub
      End If

Err.Clear
End Sub

' Borrowing Michael's code from
' http://vboffice.net/en/developers/find-folder-by-name

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
    Else
      LoopFolders F.Folders
      If Not m_Folder Is Nothing Then Exit For
    End If
  Next
End Sub