Эффективность RegEx в Outlook VBA

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

1. Да, код крайне неэффективен - вам никогда не следует перебирать все элементы в папке.Используйте Items.Find/FindNext или Items.Restrict, чтобы сделать работу.Эти методы не поддерживают RegEx, но (если вам действительно необходимо использовать RegEx), вы должны по крайней мере использовать эти методы для фильтрации потенциальных совпадений.

См. Документы Microsoft для формата запроса и примеров.

Также обратите внимание, что вы используете цикл «для каждого», когда изменяете ту же коллекцию (вызывая Move) - это заставит вас пропустить некоторые элементы.Всегда используйте нисходящий цикл из Items.Count down to 1 step -1 (где возвращаются элементы, предпочтительно возвращаемые Items.Restrict - см. # 1).

Answer 2

Я не эксперт по Regex, поэтому я использую тестовую систему, чтобы помочь мне в разработке паттернов.Я попытался сопоставить ваш шаблон и некоторые варианты с рядом строк, которые соответствуют вашим предметам.Раньше я не думал о синхронизации разных паттернов, но теперь добавил это в качестве опции к своему тестовому устройству.Приведенные ниже результаты оказались не такими, как я ожидал.

Pattern        Text                   Duration

(Reg).*(Exp)   xxxRegyyyExpzzz        0.00000216
(Reg).*(Exp)   xxxxRegExpzzz          0.00000212
(Reg).*(Exp)   xxxxxRegyEyyExpzzz     0.00000220
(Reg).*(Exp)   xxxxxxRegyyExyExpzzz   0.00000220

Reg.*Exp       xxxRegyyyExpzzz        0.00000199
Reg.*Exp       xxxxRegExpzzz          0.00000198
Reg.*Exp       xxxxxRegyEyyExpzzz     0.00000204
Reg.*Exp       xxxxxxRegyyExyExpzzz   0.00000205

Reg.*?Exp      xxxRegyyyExpzzz        0.00000205
Reg.*?Exp      xxxxRegExpzzz          0.00000188
Reg.*?Exp      xxxxxRegyEyyExpzzz     0.00000214
Reg.*?Exp      xxxxxxRegyyExyExpzzz   0.00000220

Синхронизация подпрограмм VBA сложна, поскольку фоновый интерпретатор и подпрограммы ОС могут существенно влиять на время.Я должен увеличить количество повторений до 10 000 000, прежде чем общая продолжительность будет достаточной для того, чтобы я посчитал среднюю продолжительность надежной.

Как видите, удаление скобок захвата экономит немного времени, хотя вам понадобятся тысячи электронных писем.прежде чем вы заметите.Только количество символов между "Reg" и "Exp", кажется, имеет большое влияние.

Я не понимаю, почему первые два шаблона работают..* считается жадным.Он должен соответствовать каждому символу до конца строки или до следующего перевода строки.Шаблон не должен найти «Exp», потому что они соответствуют .*.Только ленивый .*? должен был прекратить сопоставлять символы, когда он нашел «Exp».Либо я неправильно понял жадное сравнение, либо ленивое сопоставление, либо движок VBA Regex не рассматривает .* как жадное.

Мой вывод состоит в том, что сопоставление регулярных выражений не является причиной медленной работы вашей программы.Я предлагаю вам попробовать предложение Тима.IAmANerd2000 добавил подпрограмму, демонстрирующую предложение Тима, но с тех пор он / она удалил его.(Я вижу удаленные ответы, потому что моя репутация превышает 10 тыс.). Возможно, Тим хотел бы добавить ответ, демонстрирующий его предложение.

Я включаю ниже свой тестовый жгут, если вы считаете его полезным.Его вывод для шаблона и текста:

===========================================
   Pattern: "(Reg).*(Exp)"
      Text: "xxxRegyyyExpzzz"
Av Durat'n: 0.00000216
-------------------------------------------
     Match: 1
     Value: "RegyyyExp"
    Length: 9
FirstIndex: 3
  SubMatch: 1 "Reg"
  SubMatch: 2 "Exp"
===========================================

Option Explicit
Sub Test2()

  Dim Patterns As Variant
  Dim Texts As Variant

  Texts = Array("xxxRegyyyExpzzz", _
                "xxxxRegExpzzz", _
                "xxxxxRegyEyyExpzzz", _
                "xxxxxxRegyyExyExpzzz")

  Patterns = Array("(Reg).*(Exp)", _
                   "Reg.*Exp", _
                   "Reg.*?Exp")

  Call TestCapture(Patterns, Texts, True)

End Sub
Sub TestCapture(ByRef Patterns As Variant, ByRef Texts As Variant, _
                Optional ByVal TimeDuration As Boolean = False)

  ' Patterns      an array of patterns to be tested
  ' Texts         an array of text to be matched against the patterns
  ' TimeDuration  if True, record the average duration of the match

  ' Attempts to match each text against each pattern and reports on the result
  ' If TimeDuration is True, repeats the match 10,000,000 times and reports the
  ' average duration so the efficiency of different patterns can be determined

  Dim CountCrnt As Long
  Dim CountMax As Long
  Dim InxM As Long
  Dim InxS As Long
  Dim Matches As MatchCollection
  Dim PatternCrnt As Variant
  Dim RegEx As New RegExp
  Dim TimeEnd As Double
  Dim TimeStart As Double
  Dim SubMatchCrnt As Variant
  Dim TextCrnt As Variant

  With RegEx
    .Global = True         ' Find all matches
    .MultiLine = False     ' Match cannot extend across linebreak
    .IgnoreCase = True

    For Each PatternCrnt In Patterns
     .Pattern = PatternCrnt

      For Each TextCrnt In Texts
        Debug.Print "==========================================="
        Debug.Print "   Pattern: """ & PatternCrnt & """"
        Debug.Print "      Text: """ & TidyTextForDspl(TextCrnt) & """"
        If TimeDuration Then
          CountMax = 10000000
          TimeStart = Timer
        Else
          CountMax = 1
        End If
        For CountCrnt = 1 To CountMax
          If Not .test(TextCrnt) Then
            Debug.Print Space(12) & "Text does not match pattern"
            Exit For
          Else
            Set Matches = .Execute(TextCrnt)
            If CountCrnt = CountMax Then
              TimeEnd = Timer
              If TimeDuration Then
                Debug.Print "Av Durat'n: " & Format((TimeEnd - TimeStart) / CountMax, "0.00000000")
              End If
              If Matches.Count = 0 Then
                Debug.Print Space(12) & "Match but no captures"
              Else
                For InxM = 0 To Matches.Count - 1
                  Debug.Print "-------------------------------------------"
                  With Matches(InxM)
                    Debug.Print "     Match: " & InxM + 1
                    Debug.Print "     Value: """ & TidyTextForDspl(.Value) & """"
                    Debug.Print "    Length: " & .Length
                    Debug.Print "FirstIndex: " & .FirstIndex
                    For InxS = 0 To .SubMatches.Count - 1
                      Debug.Print "  SubMatch: " & InxS + 1 & " """ & _
                                  TidyTextForDspl(.SubMatches(InxS)) & """"
                    Next
                  End With
                Next InxM
              End If
            End If
          End If
        Next CountCrnt
      Next TextCrnt
    Next PatternCrnt
    Debug.Print "==========================================="

  End With

End Sub
Public Function TidyTextForDspl(ByVal Text As String) As String

  ' Tidy Text for dsplay by replacing white space with visible strings:
  '   Replace spaces by          ‹s› or ‹n s›
  '   Replace line feed by       ‹lf› or ‹n lf›
  '   Replace carriage return by ‹cr› or ‹n cr›
  '   Replace tab by             ‹tb› or ‹n tb›
  '   Replace non-break space by ‹nbs› or {n nbs›
  ' Where n is a count if the character repeats

  ' 15Mar16  Coded
  '  3Feb19  Replaced "{" (\x7B) and "}" (\x7D) by "‹" (\u2039) and "›" (\u203A)
  '          on the grounds that the angle quotation marks were not likely to
  '          appear in text to be displayed.

  Dim InsStr As String
  Dim InxWsChar As Long
  Dim NumWsChar As Long
  Dim PosWsChar As Long
  Dim RetnVal As String
  Dim WsCharCrnt As Variant
  Dim WsCharValue As Variant
  Dim WsCharDspl As Variant

  WsCharValue = Array(" ", vbLf, vbCr, vbTab, Chr(160))
  WsCharDspl = Array("s", "lf", "cr", "tb", "nbs")

  RetnVal = Text
  For InxWsChar = LBound(WsCharValue) To UBound(WsCharValue)
    Do While True
      PosWsChar = InStr(1, RetnVal, WsCharValue(InxWsChar))
      If PosWsChar = 0 Then
        Exit Do
      End If
      NumWsChar = 1
      Do While Mid(RetnVal, PosWsChar + NumWsChar, 1) = WsCharValue(InxWsChar)
        NumWsChar = NumWsChar + 1
      Loop
      If NumWsChar = 1 Then
        InsStr = "‹" & WsCharDspl(InxWsChar) & "›"
      Else
        InsStr = "‹" & NumWsChar & WsCharDspl(InxWsChar) & "›"
      End If
      RetnVal = Mid(RetnVal, 1, PosWsChar - 1) & InsStr & Mid(RetnVal, PosWsChar + NumWsChar)
    Loop
  Next

  TidyTextForDspl = RetnVal

End Function