Recognize pattern for categorizing mails then move mail to folders that are created if needed

Question

I developed a email-filtering VBA code, so I can recognize the pattern [ABC] for categorizing mails.

I expect incoming mails to be moved to folders and categorized.

The folders are to be created if needed.

Target :

extract words within [this Bracket], and specific code such as CMX , INC

Subject : [ABC] --> create inbox folder ABC

Subject : [CMX] --> create inbox folder ABC

Subject : CMX --> create inbox folder CMX

Subject : INC000000156156 --> create inbox folder INC and sub-folder INC000000156156

The code does not create folders, especially when I delete the folder with mails.

Private Sub Application_NewMail()
    
    Dim olFld As Outlook.MAPIFolder
    Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)
    olFld.Items.Sort "[ReceivedTime]", False
    Dim olMail As Outlook.MailItem
    Set olMail = olFld.Items.GetFirst
    MyNiftyFilter olMail
End Sub

Private Sub MyNiftyFilter(Item As Outlook.MailItem)
    Debug.Print Item
    Debug.Print Item.Subject
    
    Dim Matches As Variant
    Dim RegExp As New VBScript_RegExp_55.RegExp
    Dim Pattern As String
    
    Dim Email_Subject As String
    Pattern = "\[(.*?)\]"
    Email_Subject = Item.Subject

    With RegExp
        .Global = False
        .Pattern = Pattern
        .IgnoreCase = True
    Set Matches = .Execute(Email_Subject)
    End With
    
    Dim olFld As Outlook.MAPIFolder
    Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)

    Dim SubFolder As Outlook.MAPIFolder

        If Matches.Count > 0 Then
            Debug.Print Matches(0)
            Debug.Print Matches(0).SubMatches(0)
            Set oloUtlook = CreateObject("Outlook.Application")
            Set ns = oloUtlook.GetNamespace("MAPI")
            Set itm = ns.GetDefaultFolder(olFolderInbox)
            On Error Resume Next
            Set SubFolder = itm.Folders.Item(Matches(0).SubMatches(0))
            If SubFolder Is Nothing Then
                SubFolder = itm.Folders.Add(Matches(0).SubMatches(0))
            End If
            Item.Move SubFolder
        End If

    Set RegExp = Nothing
    Set Matches = Nothing
    Set Item = Nothing

End Sub

Answer 1

Try something like this

Private Sub Application_NewMail()

    Dim olFld As Outlook.MAPIFolder
    Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)
    olFld.Items.Sort "[ReceivedTime]", False
    Dim olMail As Outlook.MailItem
    Set olMail = olFld.Items.GetFirst
    MyNiftyFilter olMail
End Sub

Private Sub MyNiftyFilter(Item As Outlook.MailItem)


    Debug.Print Item
    Debug.Print Item.Subject

    Dim Matches As Variant
    Dim RegExp As New VBScript_RegExp_55.RegExp
    Dim Pattern As String
    Dim Email_Subject As String

    Pattern = "(([\w-\s]*)\s*)"

    Email_Subject = Item.Subject

    With RegExp
        .Global = False
        .Pattern = Pattern
        .IgnoreCase = True
    Set Matches = .Execute(Email_Subject)
    End With

        If Matches.Count > 0 Then
            Debug.Print Matches(0) ' Print on Immediate Window 
        End If

    Set RegExp = Nothing
    Set Matches = Nothing
    Set Item = Nothing

End Sub

for the regex use \[(.*?)\] *demo https://regex101.com/r/U3bjOf/1

https://regex101.com/r/U3bjOf/2

    If Matches.Count > 0 Then
        Debug.Print Matches(0) ' full match [ABC]
        Debug.Print Matches(0).submatches(0) ' submatch ABC
    End If

---

to create sub-folder use function like this

'//  Function - Check folder Exist
Private Function FolderExists(Inbox As MAPIFolder, FolderName As String)
    Dim Sub_Folder As MAPIFolder

    On Error GoTo Exit_Err
    Set Sub_Folder = Inbox.Folders(FolderName)

    FolderExists = True
        Exit Function

Exit_Err:
    FolderExists = False

End Function

then call it

    Dim olFld As Outlook.MAPIFolder
    Set olFld = Outlook.Session.GetDefaultFolder(olFolderInbox)

    Dim SubFolder As Outlook.MAPIFolder

    Dim FolderName As String

    If Matches.Count > 0 Then
        Debug.Print Matches(0) ' full match [ABC]
        Debug.Print Matches(0).submatches(0) ' submatch ABC

        FolderName = Matches(0).submatches(0)

        '// Check if folder exist else create one
        If FolderExists(Inbox, FolderName) = True Then
             Set SubFolder = Inbox.Folders(FolderName)
        Else
             Set SubFolder = Inbox.Folders.Add(FolderName)
        End If

        Item.Move SubFolder
    End If