Outlook VBA中RegEx的效率

Question

我是Outlook VBA(Office 365版)的新手,我想要实现的是循环浏览文件夹中的所有电子邮件("收件箱"中的"abc@outlook.com")并移动主题与特定主题相匹配的电子邮件RegEx到另一个文件夹.

由于这是我第一次使用Outlook VBA,并且不熟悉其对象模型,因此我一直在努力拼凑出一个解决方案.

这是我到目前为止(我通过编写组件步骤的简单示例,然后构建最终的复合函数)来学习:

Sub RegExpMoveEmailToFolderSO()
    Dim MyFolder As Outlook.Folder
    Dim MyNS As NameSpace
    Dim MyEmail As Outlook.MailItem
    Dim MyItems As Outlook.Items
    Dim CountMatches As Integer
    Dim MySubject As String
    Dim MyRegExp As RegExp
    Dim MyDestinationFolder As Outlook.Folder


    Set MyNS = Application.GetNamespace("MAPI")
    Set MyFolder = MyNS.Folders("xyz@abc.com").Folders("Inbox")
    Set MyDestinationFolder = MyNS.Folders("uvw@def.com").Folders("Inbox")
    Set MyItems = MyFolder.Items
    Set MyRegExp = New RegExp

    CountMatches = 1
    MyRegExp.Pattern = "(Reg).*(Exp)"

    For Each Item In MyItems
        MySubject = Item.Subject
        If MyRegExp.Test(MySubject) Then
              Item.Move MyDestinationFolder
              CountMatches = CountMatches + 1
        End If
    Next

    MsgBox "The total number of emails moved is: " & CountMatches & "."
End Sub

这显然是有效的,但速度相当慢 - 与在Outlook中使用类似的规则相比,相当慢一点,并且在我的i7机器上旋转了粉丝.我想知道这个代码是否有任何明显低效的问题,以及是否有任何方法可以提高效率并降低处理器的负担.

Answer 1

我不是正则表达式专家，因此我使用测试工具来帮助我开发模式。我尝试将您的模式和一些与您的主题匹配的字符串进行一些变体。我之前没有想过对不同的模式进行计时，但现在我已将其作为一个选项添加到我的测试工具中。下面的结果并不符合我的预期。

\n\n

Pattern        Text                   Duration\n\n(Reg).*(Exp)   xxxRegyyyExpzzz        0.00000216\n(Reg).*(Exp)   xxxxRegExpzzz          0.00000212\n(Reg).*(Exp)   xxxxxRegyEyyExpzzz     0.00000220\n(Reg).*(Exp)   xxxxxxRegyyExyExpzzz   0.00000220\n\nReg.*Exp       xxxRegyyyExpzzz        0.00000199\nReg.*Exp       xxxxRegExpzzz          0.00000198\nReg.*Exp       xxxxxRegyEyyExpzzz     0.00000204\nReg.*Exp       xxxxxxRegyyExyExpzzz   0.00000205\n\nReg.*?Exp      xxxRegyyyExpzzz        0.00000205\nReg.*?Exp      xxxxRegExpzzz          0.00000188\nReg.*?Exp      xxxxxRegyEyyExpzzz     0.00000214\nReg.*?Exp      xxxxxxRegyyExyExpzzz   0.00000220\n

\n\n

对 VBA 例程进行计时很困难，因为后台解释器和操作系统例程会显着影响计时。在总持续时间足以让我认为平均持续时间可靠之前，我必须将重复次数增加到 10,000,000 次。

\n\n

正如您所看到的，删除捕获括号可以节省一点时间，尽管您需要发送数千封电子邮件才能注意到。只有“Reg”和“Exp”之间的字符数似乎有很大影响。

\n\n

我不明白为什么前两种模式有效。 .*据说是贪心。它应该匹配直到字符串末尾或下一个换行符的每个字符。该模式不应找到“Exp”，因为它们与.*. 只有懒惰的人才.*?应该在发现“Exp”时停止匹配字符。要么是我误解了贪婪匹配与惰性匹配，要么是 VBA Regex 引擎不将其视为.*贪婪匹配。

\n\n

我的结论是正则表达式匹配并不是导致你的例程缓慢的原因。我建议你尝试蒂姆的建议。IAmANerd2000 添加了一个例程来演示 Tim 的建议，但他/她已将其删除。（我可以看到已删除的答案，因为我的声誉超过 10K。）也许蒂姆想添加一个答案来证明他的建议。

\n\n

我在下面列出了我的测试工具，以防您发现它有帮助。每个模式和文本的输出是：

\n\n

===========================================\n   Pattern: "(Reg).*(Exp)"\n      Text: "xxxRegyyyExpzzz"\nAv Durat\'n: 0.00000216\n-------------------------------------------\n     Match: 1\n     Value: "RegyyyExp"\n    Length: 9\nFirstIndex: 3\n  SubMatch: 1 "Reg"\n  SubMatch: 2 "Exp"\n===========================================\n\nOption Explicit\nSub Test2()\n\n  Dim Patterns As Variant\n  Dim Texts As Variant\n\n  Texts = Array("xxxRegyyyExpzzz", _\n                "xxxxRegExpzzz", _\n                "xxxxxRegyEyyExpzzz", _\n                "xxxxxxRegyyExyExpzzz")\n\n  Patterns = Array("(Reg).*(Exp)", _\n                   "Reg.*Exp", _\n                   "Reg.*?Exp")\n\n  Call TestCapture(Patterns, Texts, True)\n\nEnd Sub\nSub TestCapture(ByRef Patterns As Variant, ByRef Texts As Variant, _\n                Optional ByVal TimeDuration As Boolean = False)\n\n  \' Patterns      an array of patterns to be tested\n  \' Texts         an array of text to be matched against the patterns\n  \' TimeDuration  if True, record the average duration of the match\n\n  \' Attempts to match each text against each pattern and reports on the result\n  \' If TimeDuration is True, repeats the match 10,000,000 times and reports the\n  \' average duration so the efficiency of different patterns can be determined\n\n  Dim CountCrnt As Long\n  Dim CountMax As Long\n  Dim InxM As Long\n  Dim InxS As Long\n  Dim Matches As MatchCollection\n  Dim PatternCrnt As Variant\n  Dim RegEx As New RegExp\n  Dim TimeEnd As Double\n  Dim TimeStart As Double\n  Dim SubMatchCrnt As Variant\n  Dim TextCrnt As Variant\n\n  With RegEx\n    .Global = True         \' Find all matches\n    .MultiLine = False     \' Match cannot extend across linebreak\n    .IgnoreCase = True\n\n    For Each PatternCrnt In Patterns\n     .Pattern = PatternCrnt\n\n      For Each TextCrnt In Texts\n        Debug.Print "==========================================="\n        Debug.Print "   Pattern: """ & PatternCrnt & """"\n        Debug.Print "      Text: """ & TidyTextForDspl(TextCrnt) & """"\n        If TimeDuration Then\n          CountMax = 10000000\n          TimeStart = Timer\n        Else\n          CountMax = 1\n        End If\n        For CountCrnt = 1 To CountMax\n          If Not .test(TextCrnt) Then\n            Debug.Print Space(12) & "Text does not match pattern"\n            Exit For\n          Else\n            Set Matches = .Execute(TextCrnt)\n            If CountCrnt = CountMax Then\n              TimeEnd = Timer\n              If TimeDuration Then\n                Debug.Print "Av Durat\'n: " & Format((TimeEnd - TimeStart) / CountMax, "0.00000000")\n              End If\n              If Matches.Count = 0 Then\n                Debug.Print Space(12) & "Match but no captures"\n              Else\n                For InxM = 0 To Matches.Count - 1\n                  Debug.Print "-------------------------------------------"\n                  With Matches(InxM)\n                    Debug.Print "     Match: " & InxM + 1\n                    Debug.Print "     Value: """ & TidyTextForDspl(.Value) & """"\n                    Debug.Print "    Length: " & .Length\n                    Debug.Print "FirstIndex: " & .FirstIndex\n                    For InxS = 0 To .SubMatches.Count - 1\n                      Debug.Print "  SubMatch: " & InxS + 1 & " """ & _\n                                  TidyTextForDspl(.SubMatches(InxS)) & """"\n                    Next\n                  End With\n                Next InxM\n              End If\n            End If\n          End If\n        Next CountCrnt\n      Next TextCrnt\n    Next PatternCrnt\n    Debug.Print "==========================================="\n\n  End With\n\nEnd Sub\nPublic Function TidyTextForDspl(ByVal Text As String) As String\n\n  \' Tidy Text for dsplay by replacing white space with visible strings:\n  \'   Replace spaces by          \xe2\x80\xb9s\xe2\x80\xba or \xe2\x80\xb9n s\xe2\x80\xba\n  \'   Replace line feed by       \xe2\x80\xb9lf\xe2\x80\xba or \xe2\x80\xb9n lf\xe2\x80\xba\n  \'   Replace carriage return by \xe2\x80\xb9cr\xe2\x80\xba or \xe2\x80\xb9n cr\xe2\x80\xba\n  \'   Replace tab by             \xe2\x80\xb9tb\xe2\x80\xba or \xe2\x80\xb9n tb\xe2\x80\xba\n  \'   Replace non-break space by \xe2\x80\xb9nbs\xe2\x80\xba or {n nbs\xe2\x80\xba\n  \' Where n is a count if the character repeats\n\n  \' 15Mar16  Coded\n  \'  3Feb19  Replaced "{" (\\x7B) and "}" (\\x7D) by "\xe2\x80\xb9" (\\u2039) and "\xe2\x80\xba" (\\u203A)\n  \'          on the grounds that the angle quotation marks were not likely to\n  \'          appear in text to be displayed.\n\n  Dim InsStr As String\n  Dim InxWsChar As Long\n  Dim NumWsChar As Long\n  Dim PosWsChar As Long\n  Dim RetnVal As String\n  Dim WsCharCrnt As Variant\n  Dim WsCharValue As Variant\n  Dim WsCharDspl As Variant\n\n  WsCharValue = Array(" ", vbLf, vbCr, vbTab, Chr(160))\n  WsCharDspl = Array("s", "lf", "cr", "tb", "nbs")\n\n  RetnVal = Text\n  For InxWsChar = LBound(WsCharValue) To UBound(WsCharValue)\n    Do While True\n      PosWsChar = InStr(1, RetnVal, WsCharValue(InxWsChar))\n      If PosWsChar = 0 Then\n        Exit Do\n      End If\n      NumWsChar = 1\n      Do While Mid(RetnVal, PosWsChar + NumWsChar, 1) = WsCharValue(InxWsChar)\n        NumWsChar = NumWsChar + 1\n      Loop\n      If NumWsChar = 1 Then\n        InsStr = "\xe2\x80\xb9" & WsCharDspl(InxWsChar) & "\xe2\x80\xba"\n      Else\n        InsStr = "\xe2\x80\xb9" & NumWsChar & WsCharDspl(InxWsChar) & "\xe2\x80\xba"\n      End If\n      RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & InsStr & Mid(RetnVal, PosWsChar + NumWsChar)\n    Loop\n  Next\n\n  TidyTextForDspl = RetnVal\n\nEnd Function\n

\n