Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private WithEvents objSentItems As Outlook.Items
Dim strCode As String
Dim Code As String

Private m_Folder As Outlook.MAPIFolder
Private m_Find As String

' False is slower but does not lock outlook up
' True is faster but outlook may not respond
Private Const SpeedUp As Boolean = False

Private Sub Application_Startup()

Dim objInboxFolder As Outlook.Folder
Dim objSentFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")

'Set the folder and items to watch:
Set objInboxFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objItems = objInboxFolder.Items

Set objSentFolder = objNS.GetDefaultFolder(olFolderSentMail)
Set objSentItems = objSentFolder.Items

Set objSentFolder = Nothing
Set objInboxFolder = Nothing
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
If Item.Class = olMail Then
    MoveMessages Item
End If
End Sub

Private Sub objSentItems_ItemAdd(ByVal Item As Object)
If Item.Class = olMail Then
    MoveMessages Item
End If
End Sub

Public Sub MoveMessages(ByVal Item As MailItem)
Dim strText As String
'' find the code
strText = Item.Subject & vbCrLf & Item.Body
strCode = ExtractText(strText)
If strCode = "" Then
    Exit Sub
End If


' 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


Function ExtractText(Str As String) ' As String
Dim regEx As New RegExp
Dim NumMatches As MatchCollection
Dim M As Match

'this pattern looks for 6 digits in the subject
With regEx
    .Pattern = "(CB[0-9]{6})"
    .IgnoreCase = True
    .Global = False
End With

Set NumMatches = regEx.Execute(Str)
If NumMatches.Count = 0 Then
      ExtractText = ""
Else
Set M = NumMatches(0)
  ExtractText = M.SubMatches(0)
End If
Code = ExtractText
End Function

' 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).Parent.Folders("Clients")
  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