Vba 如何通过正则表达式和VB触发Outlook 2010传入电子邮件的自动分类代码

我想为Outlook 2010开发一个自定义规则来过滤电子邮件。使用正则表达式的预期结果应为：

主题：[ABC]->创建收件箱文件夹ABC

我已打开信任中心的宏。当涉及到实现和测试时，无法触发此流

你能告诉我怎么触发宏吗

这是我用VBA编写的代码

Public Enum Actions
    ACT_DELIVER = 0
    ACT_DELETE = 1
    ACT_QUARANTINE = 2
End Enum


Sub MyNiftyFilter(Item As Outlook.MailItem)
    Dim Matches, Match
    Dim regex As New RegExp
    Dim mc As system.Text.RegularExpressions.MatchCollection
    regex.IgnoreCase = True
    Dim GoodRegEx As New RegExp
    GoodRegEx.IgnoreCase = True

    ' assume mail is good'
    Dim Message As String: Message = ""
    Dim GroupName As String: GroupName = ""
    Dim Action As Actions: Action = ACT_DELIVER

    ' SPAM TEST: Illegal word in subject'
    regex.Pattern = "(v\|agra|erection|penis|boner|pharmacy|painkiller|vicodin|valium|adderol|sex med|pills|pilules|viagra|cialis|levitra|rolex|diploma)"
    GoodRegEx.Pattern = "(([\w-\s]*)\s*)"

    If Action = ACT_DELIVER Then
        If regex.test(Item.Subject) Then
            Action = ACT_QUARANTINE
            Set Matches = regex.Execute(Item.Subject)
            Message = "SPAM: Subject contains restricted word(s): " & JoinMatches(Matches, ",")
        ElseIf GoodRegEx.test(Item.Subject) Then
            Dim results(mc.Count - 1) As String
            For i = 0 To results.Length - 1
                results(i) = mc(i).Value
                If i = 0 Then
                    GroupName = results(i)
                    Set MailDest = ns.Folders(GroupName)
                    Item.Move MailDest
                End If
            Next

        End If
    End If

    ' other tests'

    Select Case Action
        Case Actions.ACT_QUARANTINE
            Dim ns As Outlook.NameSpace
            Set ns = Application.GetNamespace("MAPI")

            Dim junk As Outlook.Folder
            Set junk = ns.GetDefaultFolder(olFolderJunk)

            Item.Subject = "SPAM: " & Item.Subject
            If Item.BodyFormat = olFormatHTML Then
                Item.HTMLBody = "<h2>" & Message & "</h2>" & Item.HTMLBody
            Else
                Item.Body = Message & vbCrLf & vbCrLf & Item.Body
            End If

            Item.Save
            Item.Move junk

        Case Actions.ACT_DELETE
            ' similar to above, but grab Deleted Items folder as destination of move'

        Case Actions.ACT_DELIVER
            ' do nothing'
    End Select
End Sub


Private Function JoinMatches(Matches, Delimeter)
    Dim RVal: RVal = ""

    For Each Match In Matches
        If Len(RVal) <> 0 Then
            RVal = RVal & ", " & Match.Value
        Else
            RVal = RVal & Match.Value
        End If
    Next

    JoinMatches = RVal
End Function


Private Sub Application_NewMail(Item As Outlook.MailItem)
    ' your code here
    MyNiftyFilter (Item)
End Sub

---

您需要在以下方法中运行代码-当新邮件到来时，会触发此方法

不要硬键入方法，而是从声明列表中选择，请参见图片：

 Private Sub Application_NewMail()
    ' your code here
 End Sub

将一个或多个项添加到指定集合时发生。当大量项目同时添加到文件夹中时，此事件不会运行

---

我有程序错误。请告诉我错误在哪里？对不起，我看不见？哪一行和哪一个错误？感谢尽管这种方法有效，但它将停止处理时间或多封邮件。。出现过。我看到此错误。Iser定义的类型未在此代码行定义：Dim mc As system.Text.RegularExpressions.MatchCollectionU是否在引用列表中检查了系统？我打开宏的配置是否没有问题？@Rajuyorppe创建自签名证书无法在我的窗口资源管理器上创建我的证书，因为我我使用的是windows 10您可以使用任何类似的项目进行测试您是如何尝试将子MyNiftyFilterItem作为Outlook.MailItem运行的？

Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Set olNs = Application.GetNamespace("MAPI")

    Dim Inbox  As Outlook.MAPIFolder
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)

    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        Debug.Print Item.Subject
        MyNiftyFilter Items
    End If
End Sub