Outlook VBA代碼極其緩慢

我編寫了這段代碼，用於尋找所有郵箱內的所有郵件中的特定字符串（平均每個郵箱100個郵箱（總計10個郵箱））。Outlook VBA代碼極其緩慢

事情是......代碼有效，但它太慢了，甚至凍結了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

來源

2015-04-02 AndroidDev

一兩件事：我測試剛剛在所有科目檢查代碼，它的效果要好得多。但我還需要檢查屍體，這部分似乎是問題所在。 – AndroidDev 2015-04-02 20:10:02

我不完全知道爲什麼你需要DoEvents在每個迭代，但是你可能需要在你的圖形用戶界面，否則只是做一次底。

我相信ReDim的數組一直不是很有效率。爲什麼不使用集合？ Collections vs Array

你可以改變你的代碼，包括

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

來源

2015-04-02 20:33:30 agu

你說得對。它會加快一點，但正如我所說的，關鍵部分是：如果InStr（1，lMsg.Body，Word，vbTextCompare）> 0 – AndroidDev 2015-04-02 20:52:06

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）搜索字符串執行搜索。

來源

2015-04-02 20:52:09

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

來源

2015-04-02 23:47:04

我已經建議使用這些函數。 – 2015-04-03 05:39:19

對你有好處。我提供了OP需要使用的實際過濾器。 – 2015-04-03 13:35:29

Outlook VBA代碼極其緩慢

回答

相關問題