Open emails based on the date and time they were received using VBA .Restrict method

I am writing a macro that opens an email based on the sender, subject, and received date/time of the email. Here is what I have so far:

Sub ForwardEmail()
    Dim myNamespace As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim objForward As Outlook.MailItem


Dim submissionDate As String, senderEmail As String
Dim subjectEmail As String
Dim rownum As Long
Dim OutlookApp As Object


rownum = 2
submissionDate = Cells(rownum, 3).Value

senderEmail = Cells(rownum, 6).Value
subjectEmail = Cells(rownum, 5).Value
Set OutlookApp = CreateObject("Outlook.Application")
Set myNamespace = OutlookApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(6)
Set myItems = myFolder.Items
Test = "[Subject] = '" & subjectEmail & "' AND [SenderEmailAddress] = '" & senderEmail & "' AND [ReceivedTime] >= '" & Format(submissionDate, "DDDDD HH:NN") & "'"



Set myRestrictItems = myItems.Restrict(Test)

For Each FilteredItem In myRestrictItems
   Set objForward = FilteredItem.Forward
   With objForward
   .To = Cells(rownum, 19)
   .Display
   End With
   Next FilteredItem
End Sub

The date and time of the email are pulled from a particular cell in the excel worksheet. The format that it is displayed as in excel sheet is something like this: 6/23/2025 13:13. When using my code above, I am unable to get the Macro to open the desired email. However, if I hard code the filter string as follows, the emails open successfully:

Test = "[Subject] = '" & subjectEmail & _
   "' AND [SenderEmailAddress] = '" & senderEmail & _
 "' AND [ReceivedTime] >= '" & Format("6/23/2025 00:00, "DDDDD HH:NN") & "'"

Can someone help me figure out where I'm going wrong? I would like to open an email that was received on a particular date, at a particular time. I'm sure the answer lies in the date format, but I am having trouble figuring it out.

Solution

If multiple emails match (e.g. same sender, subject, and time within a minute), you'll get all of them, you can add an upper bound like <= if needed, And another thing is Outlook ignores seconds in Restrict. If you need more precision, you have to manually loop through and check ReceivedTime against submissionDate in code after restricting.

Something like this:

Sub ForwardEmail()
    Dim myNamespace As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim objForward As Outlook.MailItem
    Dim FilteredItem As Object

    Dim submissionDate As Date 'Must be Date, not String
    Dim senderEmail As String
    Dim subjectEmail As String
    Dim rownum As Long
    Dim OutlookApp As Object
    Dim filterString As String

    rownum = 2
    submissionDate = Cells(rownum, 3).Value '<-This must be a valid Date
    senderEmail = Cells(rownum, 6).Value
    subjectEmail = Cells(rownum, 5).Value

    Set OutlookApp = CreateObject("Outlook.Application")
    Set myNamespace = OutlookApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(6) '6 = olFolderInbox
    Set myItems = myFolder.Items
    myItems.Sort "[ReceivedTime]", True 'Sort for Restrict to work properly

    'Format the filter string in US locale format
    filterString = "[Subject] = '" & Replace(subjectEmail, "'", "''") & "'" & _
        " AND [SenderEmailAddress] = '" & senderEmail & "'" & _
        " AND [ReceivedTime] >= '" & Format(submissionDate, "mm/dd/yyyy hh:nn") & "'"

    Set myRestrictItems = myItems.Restrict(filterString)

    For Each FilteredItem In myRestrictItems
        If TypeOf FilteredItem Is Outlook.MailItem Then
            Set objForward = FilteredItem.Forward
            With objForward
                .To = Cells(rownum, 19).Value
                .Display
            End With
        End If
    Next FilteredItem
End Sub

Edit:

My bad, Outlook's Restrict uses minute-level precision only. The filter [ReceivedTime] >= '6/20/2025 1:13' returns all emails received at or after 6/20/2025 1:13:00 PM, and since Outlook ignores seconds, even something like 6/23/2025 5:39 PM qualifies. it was not filtering on the upper bound (<=) or manually verifying timestamps, so all later emails (potentially days later) still match.

This should fix it:

Sub ForwardEmail()
    Dim myNamespace As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim objForward As Outlook.MailItem
    Dim FilteredItem As Object

    Dim submissionDate As Date
    Dim senderEmail As String
    Dim subjectEmail As String
    Dim rownum As Long
    Dim OutlookApp As Object
    Dim filterString As String
    Dim upperBoundDate As Date

    rownum = 2
    submissionDate = Cells(rownum, 3).Value 'Must be Excel Date/Time
    upperBoundDate = submissionDate + TimeSerial(0, 1, 0) '1 minute window to account for Outlook's precision
    senderEmail = Cells(rownum, 6).Value
    subjectEmail = Cells(rownum, 5).Value

    Set OutlookApp = CreateObject("Outlook.Application")
    Set myNamespace = OutlookApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(6) ' Inbox
    Set myItems = myFolder.Items
    myItems.Sort "[ReceivedTime]", True

    'US date format and doubled single quotes in Subject
    filterString = "[Subject] = '" & Replace(subjectEmail, "'", "''") & "'" & _
        " AND [SenderEmailAddress] = '" & senderEmail & "'" & _
        " AND [ReceivedTime] >= '" & Format(submissionDate, "mm/dd/yyyy hh:nn") & "'" & _
        " AND [ReceivedTime] <= '" & Format(upperBoundDate, "mm/dd/yyyy hh:nn") & "'"

    Set myRestrictItems = myItems.Restrict(filterString)

    For Each FilteredItem In myRestrictItems
        If TypeOf FilteredItem Is Outlook.MailItem Then
            'added an Extra check for exact match
            If Abs(DateDiff("s", FilteredItem.ReceivedTime, submissionDate)) <= 30 Then
                Set objForward = FilteredItem.Forward
                With objForward
                    .To = Cells(rownum, 19).Value
                    .Display
                End With
                Exit For 'this will Stop after first match
            End If
        End If
    Next FilteredItem
End Sub