Searching in shared folder limited to 250 in Outlook - vba

Question

At work we are using Outlook 2016 and we have a shared folder. I am trying to count those emails in a subfolder of this shared folder which have a specified text in their body. I got one solution, but that is too slow (there is thousands of emails in one month).
My first solution, which works:
Sub SearchBody()
Dim myItems As Outlook.Items
Dim ShareInbox As Outlook.MAPIFolder
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim SubFolder As Object
Dim i As Integer
Dim myRestrictItems As Outlook.Items
Dim myItem As Object
Dim z As Integer
Dim dateStart As Date
i = 0
dateStart = DateTime.now
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("email#email.com")
Set ShareInbox = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set SubFolder = ShareInbox.Parent.Folders("SomeSubFolder")
Set myItems = SubFolder.Items
Set myRestrictItems = myItems.Restrict("[SentOn]>='2/1/2018' AND [SentOn]<'3/1/2018'")
For z = myRestrictItems.Count To 1 Step -1
If InStr(1, myRestrictItems(z).Body, "SomeStringToSearch") > 0 Then
i = i + 1
End If
Next
MsgBox i & vbNewLine & Format(DateTime.now - dateStart, "hh:mm:ss")
End Sub
So it works, but too slow (7-10 minutes).
My next code is:
Sub SearchBody2()
Dim table As Outlook.table
Dim filter As String
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim ShareInbox As Outlook.MAPIFolder
Dim SubFolder As Object
Dim row As Outlook.row
Dim myRestrictItems As Outlook.Items
Dim myItems As Outlook.Items
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%SomeStringToSearch%'"
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("email#email.com")
Set ShareInbox = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set SubFolder = ShareInbox.Parent.Folders("SomeSubFolder")
Set table = SubFolder.GetTable(filter, Outlook.OlTableContents.olUserItems)
MsgBox table.GetRowCount
End Sub
(I know that in this code there is no filter for date like in the first)
This works too, until it reaches 250 hits: it stops then.
Is there any solution to avoid the stop of the search? I am not admin of this shared folder, so I have no rights for settings.
Folder tree:

Answer 1

Your SubFolder Should be Set SubFolder = ShareInbox.folders("SomeSubFolder")
To add Date to your filter then example would be
filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '02/01/2018' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '02/28/2018' And " & _
Chr(34) & "urn:schemas:httpmail:textdescription" & _
Chr(34) & "Like '%SomeStringToSearch%'"
If your having trouble working with shared folder then you can use CurrentFolder Property which represents the current folder displayed in the explorer
Below example has loop just for testing- deleted if not need it
Option Explicit
Public Sub Example()
Dim TargetFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
If TargetFolder Is Nothing Then Set TargetFolder = ActiveExplorer.CurrentFolder
Debug.Print TargetFolder.Name
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '02/01/2018' AND " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '02/28/2018' AND " & _
Chr(34) & "urn:schemas:httpmail:textdescription" & _
Chr(34) & "Like '%SomeStringToSearch%'"
Set Items = TargetFolder.Items.Restrict(Filter)
MsgBox (Items.Count & " Items in " & TargetFolder.Name)
Debug.Print Items.Count & " Items in " & TargetFolder.Name
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject 'Immediate Window
Next
End Sub