Outlook запускает скрипт VBA по электронной почте для перемещения в папку на основе 6-значного номера в теме

Question

Наша компания использует 6-значный номер для наших проектов. Я пытаюсь создать скрипт, который будет искать в теме письма этот 6-значный номер, затем найти подпапку, которая начинается с этого 6-значного номера, и переместить письмо в эту папку.

В своих поисках того, как это сделать, я украл некоторый код и нашел следующее. Я вставил несколько команд MsgBox, пытаясь выяснить, все ли работает по пути. Однако, когда я запускаю код (Правила> Управление правилами и оповещениями> Запустить правила сейчас), я не получаю сообщение об ошибке и не получаю никаких сообщений MsgBox. У кого-нибудь есть мысли / комментарии о том, что я могу делать неправильно?

Sub filterbyprojectnumber(Item As Outlook.MailItem)
    Dim nsOutlook As Outlook.NameSpace
    Dim MailDest As Outlook.Folder
    Set nsOutlook = Application.GetNamespace("MAPI")
    Set RegExp = CreateObject("VBScript.RegExp")
    MsgBox Item.Subject
    RegExp.Global = True
    RegExp.Pattern = "([^\d]|^)\d{6}([^\d]|$)"
    If RegExp.Test(Item.Subject) Then
        MsgBox Item.Subject
        MailDest = FindInFolders(Application.Session.Folders, RegExp.Test(Item.Subject))
        MsgBox MailDest
        Item.Move MailDest
    End If
End Sub

Function FindInFolders(TheFolders As Outlook.Folder, Name As String)
  Dim SubFolder As Outlook.MAPIFolder

  On Error Resume Next

  Set FindInFolders = Nothing

  For Each SubFolder In TheFolders
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder
      Exit For
    Else
      Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
      If Not FindInFolders Is Nothing Then Exit For
    End If
  Next
End Function