1

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:

enter image description here

Martijn Pieters
  • 1,048,767
  • 296
  • 4,058
  • 3,343
donmichael
  • 68
  • 6
  • Does this answer your question? [Macro fails for large sets of items](https://stackoverflow.com/questions/38404254/macro-fails-for-large-sets-of-items) – niton Sep 30 '21 at 19:33

1 Answers1

0

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%'"

enter image description here

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
0m3r
  • 12,286
  • 15
  • 35
  • 71