Excel VBA Outlook search Multiple Criteria (ID and Date)

This code was derived from Excel VBA for searching in mails of Outlook.

I made adjustments to make it search a SharedMailbox which does work but the issue is that the mailbox is receiving hundreds of emails a day which makes searching time a bit longer for my liking (we have emails from early last year even). I would like to impose a 2nd search criteria, this time a date limit, like only search emails that are 2 to 3 days old.

Here is what I got:

Dim outlookapp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim projIDsearch As String
Dim myRecipient As Outlook.Recipient
Dim days2ago As Date

Set outlookapp = CreateObject("Outlook.Application")
Set olNs = outlookapp.GetNamespace("MAPI")
Set myRecipient = olNs.CreateRecipient("SharedMailboxName")
myRecipient.Resolve

'Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("x")
Set Fldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox)

Set myTasks = Fldr.Items
projIDsearch = ActiveCell.Cells(1, 4)

days2ago = DateTime.Now - 3

For Each olMail In myTasks

'If olMail.ReceivedTime > days2ago Then

If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
olMail.Display
'Exit For
End If

Next

I've looked around and found the .ReceivedTime property, which sounds like the thing that I need but I'm having a struggle on how to incorporate it into the code.

Actually I don't even know how a Variant(olMail) is able to accept the .display method and .subject property.

These are the codes that I've added but they don't seem to work:

days2ago = DateTime.Now - 3

and

If olMail.ReceivedTime > days2ago Then

Solution

You can Restrict the number of items in the loop. https://msdn.microsoft.com/en-us/library/office/ff869597.aspx

Sub test()

Dim outlookapp As Object
Dim olNs As Outlook.Namespace

Dim myFldr As Outlook.Folder
Dim objMail As Object
Dim myTasks As Outlook.Items

Dim daysAgo As Long

Dim projIDsearch As String
Dim myRecipient As Outlook.Recipient

Set outlookapp = CreateObject("Outlook.Application")
Set olNs = outlookapp.GetNamespace("MAPI")
Set myRecipient = olNs.CreateRecipient("SharedMailboxName")

myRecipient.Resolve

Set myFldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox)

projIDsearch = ActiveCell.Cells(1, 4)

' Restrict search to daysAgo
daysAgo = 3

Set myTasks = myFldr.Items.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "'")

For Each objMail In myTasks

    If (InStr(1, objMail.Subject, projIDsearch, vbTextCompare) > 0) Then
        objMail.Display
    End If

Next

End Sub