Looping through large set of mailitems freezes Outlook - vba

Question

I am trying to loop through the mailItems of different subfolders looking for a comment (with PropertyAccessor) in different stores.
My code works when given 1-3 stores and around 2000 mailItems, however as the number increases it crashes Outlook.
I have implemented:
Date filtering
MailItem release
I am trying parallely the Application.AdvancedSearch method, however not managing yet.
Sub FindEmaibyComment()
Dim Fldr As Outlook.folder
Dim Str As Outlook.Store
Dim Strs As Outlook.Stores
Dim Pfldr As Outlook.folder
Dim oRoot As Outlook.folder
Dim clearingFolder As Outlook.folder
Dim mail As MailItem
Dim TaskID As String
Set Strs = Application.Session.Stores
TaskID = InputBox("Enter the MailID you want to look for." & vbNewLine & "(For example MAIL_20200525_1502769)", "Message input", "")
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.MultiLine = False
.Global = True
.IgnoreCase = True
.Pattern = "MAIL_" & "[0-9]{8}" & "_" & "[0-9]{6,100}" ' <-- Regex match for input string, example string: MAIL_20200513_1434402
End With
Set Match = RegEx.Execute(TaskID)
If Match.Count = 1 Then
'Select the stores that contain ICE, and loop through them
For Each Str In Strs
If InStr(Str.DisplayName, "Mailbox1") > 0 Then
On Error Resume Next '--> In case no permission for the store is given, go to the next store
Set oRoot = Str.GetRootFolder
Set clearingFolder = LoopFolders(oRoot, TaskID)
End If
Next Str
If MailFound = False Then
MsgBox ("Sorry, I could not find the Email")
End If
Else
MsgBox ("Please insert the correct ID with a format as follows: MAIL_12345678_1234567")
End If
End Sub
Function LoopFolders(ByVal oFolder As Outlook.folder, TaskID As String) As Outlook.folder
Dim folders As Outlook.folders
Dim Subfolders As Outlook.folders
Dim folder As Outlook.folder
Dim SubFolder As Outlook.folder
Dim foldercount As Integer
Dim clearingFolder As Outlook.folder
On Error Resume Next
Set folders = oFolder.folders
foldercount = folders.Count
'Count folders below oFolder. This is the store level
If foldercount Then
For Each folder In folders
'Count folders below Folder. This is 1. folder level "AE01"
If folder.folders.Count > 0 Then
Set Subfolders = folder.folders
For Each SubFolder In Subfolders
'Subfolders below Folder. This is 2. folder level "Clearing", "Destination"
If InStr(SubFolder, "Destination") > 0 Then
Set LoopFolders = SubFolder
FindID TaskID, SubFolder
End If
Next SubFolder
End If
Next folder
End If
End Function
Function FindID(TaskID As String, folderClearing As Outlook.folder)
Dim PropName, Comment, MessageID As String
Dim oMail As MailItem
Dim oPA As Outlook.PropertyAccessor
Dim olFolder As Outlook.MAPIFolder
Dim olNamespace As Outlook.NameSpace
Dim inputDate, inputDay, inputYear, inputMonth, sFilter, inputDateConverted, startDay, endDay As String
inputDate = Right(Left(TaskID, 13), 8) 'Example: 20200610
inputYear = Left(inputDate, 4)
inputDay = Right(inputDate, 2)
inputMonth = Right(Left(inputDate, 6), 2)
If Left(inputDay, 1) = "0" Then
inputDay = Right(inputDay, 1)
End If
If Left(inputMonth, 1) = "0" Then
inputMonth = Right(inputMonth, 1)
End If
inputDateConverted = inputMonth & "/" & inputDay & "/" & inputYear
startDay = Format(CDate(inputDateConverted & " 00:00 AM "), "\'m/d/yyyy hh:mm AM/PM\'")
endDay = Format(CDate(inputDateConverted & " 12:00 PM"), "\'m/d/yyyy hh:mm AM/PM\'")
Set myItems = folderClearing.Items
sFilter = startDay & " > [ReceivedTime] And" & endDay & " < [ReceivedTime]"
Set myRestrictedItems = myItems.Restrict(sFilter)
For Each oMail In myRestrictedItems
'PR_TRANSPORT_COMMENTS
PropName = "http://schemas.microsoft.com/mapi/proptag/0x3004001F"
Set oPA = oMail.PropertyAccessor
Comment = oPA.GetProperty(PropName)
If InStr(1, Comment, TaskID, vbTextCompare) > 0 Then
MailFound = True
MsgBox ("Mail was found in Company Code " & folderClearing.Parent & ", let me open it for you")
oMail.Display
End
End If
Set oMail = Nothing
Next oMail
End Function

Answer 1

Restrict and Find/FindNext methods are run on the main thread which means they block the UI and the overall user experience with Outlook. Moreover, iterating over all folder and subfolders is not really a good idea for searching items. That is for AdvancedSearch was introduced!
The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about the AdvancedSearch method in the Advanced search in Outlook programmatically: C#, VB.NET article.
Using the Scope parameter, you can specify one or more folders in the same store, but you may not specify multiple folders in multiple stores. To specify multiple folders in the same store for the Scope parameter, use a comma character between each folder path and enclose each folder path in single quotes. For default folders such as Inbox or Sent Items, you can use the simple folder name instead of the full folder path.
You can run multiple searches simultaneously by calling the AdvancedSearch method in successive lines of code. However, you should be aware that programmatically creating a large number of search folders can result in significant simultaneous search activity that would affect the performance of Outlook, especially if Outlook conducts the search in online Exchange mode.
Public m_SearchComplete As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
If SearchObject.Tag = "MySearch" Then
m_SearchComplete = True
End If
End Sub
Sub TestSearchForMultipleFolders()
Dim Scope As String
Dim Filter As String
Dim MySearch As Outlook.Search
Dim MyTable As Outlook.Table
Dim nextRow As Outlook.Row
m_SearchComplete = False
'Establish scope for multiple folders
Scope = "'" & Application.Session.GetDefaultFolder( _
olFolderInbox).FolderPath _
& "','" & Application.Session.GetDefaultFolder( _
olFolderSentMail).FolderPath & "'"
'Establish filter
If Application.Session.DefaultStore.IsInstantSearchEnabled Then
Filter = Chr(34) & "urn:schemas:httpmail:subject" _
& Chr(34) & " ci_phrasematch 'Office'"
Else
Filter = Chr(34) & "urn:schemas:httpmail:subject" _
& Chr(34) & " like '%Office%'"
End If
Set MySearch = Application.AdvancedSearch( _
Scope, Filter, True, "MySearch")
While m_SearchComplete <> True
DoEvents
Wend
Set MyTable = MySearch.GetTable
Do Until MyTable.EndOfTable
Set nextRow = MyTable.GetNextRow()
Debug.Print nextRow("Subject")
Loop
End Sub

Answer 2

A common cause of mysterious failure is hiding errors with On Error Resume Next.
For Each Str In Strs
Debug.Print "Str.DisplayName: " & Str.DisplayName
If InStr(Str.DisplayName, "Mailbox1") > 0 Then
Set oRoot = Nothing ' else bypssing expected error keeps previous value in oRoot
' bypass expected error
On Error Resume Next '--> In case no permission for the store is given, go to the next store
Set oRoot = Str.GetRootFolder
' remove error bypass
' to return to normal error handling
' to deal with unexpected errors
On Error GoTo 0 ' now you can see errors and can debug your code
' Handle the bypassed error
If Not oRoot Is Nothing Then
Set clearingFolder = LoopFolders(oRoot, TaskID)
End If
End If
Next Str