Outlook run VBA script on email to move to folder based on 6-digit number in subject

Question

Our company uses a 6-digit number for our projects. I'm attempting to create a script that will search the email subject for this 6-digit number, then find the subfolder that starts with this 6-digit number, and move the email to that folder.

In my searches for how to do this I've stolen some code and come up with the below. I put in some MsgBox commands in an attempt to figure out if things are working along the way. However when I run the code (Rules>Manage Rules and Alerts>Run Rules Now) I don't get an error and I don't get any MsgBox's. Anyone have any thoughts/comments on what I might be doing wrong?

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

Answer 1

Recursive code is meant up to process all folders.

The code can be coerced into returning a folder from somewhere in the middle. There is probably a better way.

Option Explicit

Private Sub test()
    ' First open a mailitem
    ' F8 from here to step through
    filterByProjectNumber ActiveInspector.CurrentItem
End Sub

Sub filterByProjectNumber(Item As MailItem)

    Dim MailDest As Folder
    Dim RegExp As RegExp
    Dim objMatch As MatchCollection

    Dim srchName As String
    Dim fndFolder As Folder

    ' Tick the reference to Microsoft VBScript Regular Expressions
    Set RegExp = CreateObject("VBScript.RegExp")
    Debug.Print "Subject of currently open item: " & Item.Subject

    RegExp.Global = True
    RegExp.Pattern = "([^\d]|^)\d{6}([^\d]|$)"

    If RegExp.test(Item.Subject) Then

        Debug.Print "Subject found: " & Item.Subject

        Set objMatch = RegExp.Execute(Item.Subject)
        srchName = (objMatch(0).Value)

        ' In these test subjects
        '   123456 test
        '   234567
        '   test 234567 test
        '  leading and/or trailing space had to be removed

        Debug.Print "-srchName-: " & "-" & srchName & "-"
        srchName = Trim(objMatch(0).Value)
        Debug.Print "-srchName-:  " & "-" & srchName & "-"

        ' MailDest will be Nothing
        '  if there is no way to exit
        '  when "fndFolder" is found
        Set MailDest = findInFolders(Session.Folders, srchName, fndFolder)

        If Not fndFolder Is Nothing Then
            Debug.Print fndFolder.Name
            Item.Move fndFolder
        Else
            Debug.Print "No matching folder found."
        End If

    Else
        Debug.Print "No regex match"

    End If

End Sub

Function findInFolders(TheFolders As Folders, sName As String, fFolder As Folder)

    Dim subFolder As Folder

    Set findInFolders = Nothing

    For Each subFolder In TheFolders

        'Debug.Print "subFolder: " & subFolder
        'Debug.Print "    sName: " & sName

        If InStr(LCase(subFolder.Name), LCase(sName)) Then

            Debug.Print "*** subFolder: " & subFolder
            Debug.Print "***     sName: " & sName

            ' Save the found folder separately
            '  as findInFolders resets to Nothing
            Set fFolder = subFolder
            ' There may be a way to exit once the folder is found
            '  otherwise run to the end

        Else
            Set findInFolders = findInFolders(subFolder.Folders, sName, fFolder)

        End If
    Next

End Function

Note: On Error Resume Next, as seen in your original code, is nearly always detrimental to the inexperienced programmer.