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，但您可能需要在GUI中使用它，否则只需在最后执行一次。

我相信阵列的ReDim一直不是很有效率。为什么不使用Collection？ 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

您需要使用Items类的Find / FindNext或Restrict方法来查找符合条件的Outlook项目，而不是迭代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

Outlook VBA代码非常慢

3 个答案: