Outlook VBA代码极其缓慢

Question

我编写了这段代码，用于寻找所有邮箱内的所有邮件中的特定字符串（平均每个邮箱100个邮箱（总计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 

Answer 1

我不完全知道为什么你需要DoEvents在每个迭代，但是你可能需要在你的图形用户界面，否则只是做一次底。

我相信ReDim的数组一直不是很有效率。为什么不使用集合？ Collections vs Array

你可以改变你的代码，包括

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

Answer 2

For Each Element In AddressArr 
    Set lFolder = GetFolder(Element) 
    Set lItems = GetFolder(Element).Items 
    For Each lMsg In lItems 

而不是遍历在Outlook中的所有文件夹和项目，你需要用查找/ FindNext中或限制的项目类的方法来找到与您的条件匹配的Outlook项目。

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

Answer 3

使用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