Макрос Outlook 2010 VBA: объект с переменной блока не установлен в Outlook.MailItem.Subject

Question

Как системный аналитик, я разрабатываю настраиваемый модуль фильтрации электронной почты в Outlook, написанный на VBA, чтобы я мог автоматически распознавать шаблон [ABC] для категоризации писем.

Я ожидаю входящие письма в папкидолжен быть создан, если он пуст и классифицирован как:

Цель:

извлекать слова в пределах [этого Скобки] и определенный код, такой как CMX, INC

Тема:[ABC] -> создать папку входящих сообщений ABC

Тема: [CMX] -> создать папку входящих сообщений ABC

Тема: CMX -> создать папку входящих сообщений CMX

Тема: INC000000156156 -> создать папку входящих сообщений INC и подпапку INC000000156156

На самом деле код не помогает мне создавать папки,особенно когда я удаляю папку с почтой.

Не могли бы вы помочь мне проверить и посмотреть на это? Как исправить этот код в разделе создания папок?

Вот мой код

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

Попробуйте что-то вроде этого

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

для использования в регулярных выражениях \[(.*?)\] * 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

---

для создания функции использования подпапки, подобной этой

'//  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

затем назовите это

    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