Get email from Outlook to Excel specified by received date

Question

I am creating a macro to get email by subject and received date in our team shared box.

I use for loop to check all email in mailbox but it takes forever because my statement checks 1000+ mails.

How can I get email by specific date? Let's say I need email 12/1/2017 to 12/30/2017.

The key is using Restrict method but I don't know how I can use it.

Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")

Dim olShareName As Outlook.Recipient
Set olShareName = OutlookNamespace.CreateRecipient("[email protected]")
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("sharebox subfolder").Folders("sharebox subfolder2")

i = 1

For Each OutlookMail In Folder.Items

    If ((Range("From_Date").Value <= OutlookMail.ReceivedTime) And _
      (OutlookMail.ReceivedTime <= Range("To_Date").Value)) And _
      OutlookMail.Sender = "[email protected]" Then

        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime

        i = i + 1

    End If

Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

I assume the code I have to fix is:

<For Each OutlookMail In Folder.Items>

How can I make statement using Restrict Method?

Answer 1

You can create a collection of items restricted by date like this.

Option Explicit

Private Sub EmailInTimePeriod()

    Dim oOlInb As Folder
    Dim oOlItm As Object

    Dim oOlResults As Object
    Dim i As Long

    Dim sFilterLower As String
    Dim sFilterUpper As String
    Dim sFilter As String

    Dim dStart As Date
    Dim dEnd As Date

    Set oOlInb = Session.GetDefaultFolder(olFolderInbox)

    ' https://msdn.microsoft.com/en-us/library/office/ff869597.aspx

    ' 12/1/2017 to 12/30/2017
    'dStart = "2017/12/01"
    'dEnd = "2017/12/30"

    ' 1/12/2018 to 1/15/2018
    dStart = "2018/01/12"
    dEnd = "2018/01/16"

    ' Lower Bound of the range
    sFilterLower = "[ReceivedTime]>'" & Format(dStart, "DDDDD HH:NN") & "'"
    Debug.Print vbCr & "sFilterLower: " & sFilterLower


    ' *** temporary demo lines
    ' Restrict the items in the folder
    Set oOlResults = oOlInb.Items.Restrict(sFilterLower)
    Debug.Print oOlResults.count & " items."

    If oOlResults.count > 0 Then
        For i = 1 To oOlResults.count
            Set oOlItm = oOlResults(i)
            Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
        Next i
    End If
    ' *** temporary demo lines


    ' Upper Bound of the range
    sFilterUpper = "[ReceivedTime]<'" & Format(dEnd, "DDDDD HH:NN") & "'"
    Debug.Print vbCr & "sFilterUpper: " & sFilterUpper


    ' *** temporary demo lines
    ' Restrict the Lower Bound result
    Set oOlResults = oOlResults.Restrict(sFilterUpper)
    Debug.Print oOlResults.count & " items."

    If oOlResults.count > 0 Then
        For i = 1 To oOlResults.count
            Set oOlItm = oOlResults(i)
            Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
        Next i
    End If
    ' *** temporary demo lines


    ' combine the filters
    sFilter = sFilterLower & " AND " & sFilterUpper
    Debug.Print vbCr & "sFilter: " & sFilter

    Set oOlResults = oOlInb.Items.Restrict(sFilter)
    Debug.Print oOlResults.count & " items."

    If oOlResults.count > 0 Then
        For i = 1 To oOlResults.count
            Set oOlItm = oOlResults(i)
            Debug.Print oOlItm.ReceivedTime & " - " & oOlItm.subject
        Next i
    End If


ExitRoutine:
    Set oOlInb = Nothing
    Set oOlResults = Nothing
    Set oOlItm = Nothing
    Debug.Print "Done."

End Sub

Note the code is set up to be used in Outlook.