Performance Outlook VBA代码非常慢

我编写了这段代码，在所有邮箱中的所有邮件中查找特定字符串（平均每个邮箱100个mesages（总共10个邮箱））

问题是。。。代码可以工作，但速度太慢了，甚至冻结了Outlook

我能做些什么来加快速度吗

Sub InboxSeeker(Word As String)

Dim u As Integer, AddressArr() As String, Users() As String, Element As Variant, Label As Control

GetOutlook
AddressArr = QryLoop_Specific("Company", "Address", "Users", "Team", "Samples", "Address")

For Each Element In AddressArr
    Set lFolder = GetFolder(Element)
        Set lItems = GetFolder(Element).Items
        For Each lMsg In lItems
            If InStr(1, lMsg.Body, Word, vbTextCompare) > 0 Or InStr(1, lMsg.Subject, Word, vbTextCompare) > 0 Then
                DoEvents
                ReDim Preserve Users(u)
                Users(u) = QrySingleResult("Company", "FullName", "Users", "Address", Element)
                u = u + 1
            End If
        Next lMsg
Next Element

---

我不能完全确定为什么每次迭代都需要

DoEvents

，但是您可能需要在GUI中使用它，否则在最后只需要执行一次

我认为阵列的ReDim一直都不是很有效。为什么不使用集合呢？

您可以更改代码以包括

Dim Users as new Collection
...
Users.Add QrySingleResult("Company", "FullName", "Users", "Address", Element)

您需要使用items类的Find/FindNext或Restrict方法来查找与您的条件匹配的Outlook项目，而不是遍历Outlook中的所有文件夹和项目

---

我还建议使用Namespace类的方法，该方法根据指定的DAV搜索和定位（DASL）搜索字符串执行搜索。

使用Items.Find/FindNext

set item = lItems.Find("@SQL=(""urn:schemas:httpmail:textdescription"" LIKE '%something%') OR (""http://schemas.microsoft.com/mapi/proptag/0x0E1D001F"" LIKE '%something%') ")
while Not (item is Nothong)
  ... 
  set Item = lItems.FindNext
wend

---

还有一件事：我只测试了所有主题的代码，效果更好。但我也需要检查尸体，这部分似乎是问题所在。你说得对。它会加快一点，但正如我所说，关键部分是：If InStr（1，lMsg.Body，Word，vbTextCompare）>0对您有好处。我提供了OP需要使用的实际过滤器。

set item = lItems.Find("@SQL=(""urn:schemas:httpmail:textdescription"" LIKE '%something%') OR (""http://schemas.microsoft.com/mapi/proptag/0x0E1D001F"" LIKE '%something%') ")
while Not (item is Nothong)
  ... 
  set Item = lItems.FindNext
wend