How do I search between two date ranges in VBA? - excel

Question

I have hit a stumbling block and could just do with some assistance please.
I have been tasked with creating a VBA Macro that looks between two date ranges in a shared inbox sub-folder in Outlook.
If the code finds any Excel documents attached to the emails within that date range it will extract the attachments and will put them into a designated shared drive folder. All of this i had working perfectly, however, I now need to change the code slightly so that on a separate sheet it adds the date the code was last ran (this I have working also) and when the code is next ran it takes the date it last ran as the "Date from" date and searches between that date and whatever the date and time is of the time you are trying to execute the code again - this is where my code isn't working.
Here is my code so far (I am not a VBA expert and some terminology may not be correct so please go easy on my code) - I have had to replace certain sensitive info with "xxxxxx" in the code below.
Sub saveOutlookAttachments()
' For this to work, you need to ensure "Microsoft Office 16.0 Object Library" is ticked
' You can find the object library in Tools -> References
' -- start of initialise all the outlook library details needed
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.attachment
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
' -- end of initialise all the outlook library details needed
' -- start of Date from and to initialising
Dim DateStart As Date
Dim DateEnd As Date
Dim DateToCheck As String
' Get the date last ran
If Sheet2.Cells(1, 2) <> "" Then
Sheet1.Cells(2, 2) = Sheet2.Cells(1, 2)
Debug.Print "Start Date is: "; Sheet1.Cells(2, 2)
Sheet1.Cells(2, 4) = Now()
Debug.Print "End Date is: "; Sheet1.Cells(2, 4)
Else
Sheet2.Cells(1, 2) = ""
Debug.Print Sheet1.Cells(2, 2)
End If
DateStart = Sheet1.Cells(2, 2) ' Cell B2
DateEnd = Sheet1.Cells(2, 4) ' Cell B4
DateToCheck = "[ReceivedTime] >= """ & DateStart & """ And [ReceivedTime] <= """ & DateEnd & """"
Debug.Print "Date to Check is: "; DateToCheck
' -- end of Date from and to initialising
' -- start of Set ol and Set ns
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
' -- end of Set ol and Set ns
' Which folder should the script be reading from?
Set fol = ns.Folders("~ xxxxxxx ").Folders("Inbox").Folders("xxxxxxxx")
' if there is an error when the code runs then stop the script and go straight to "errordetails" found at the bottom of the screen
On Error GoTo errordetails
' For each email in the folder (Restricted to the date range entered on the Spreadsheet)
For Each i In fol.Items.Restrict(DateToCheck)
' If the email is an Outlook email
If i.Class = OlMail Then
Set mi = i
UserForm1.Show
' If there are more than 0 attachments, ie, if it finds an attachment
If mi.Attachments.Count > 0 Then
For Each at In mi.Attachments
'Debug.Print mi.SenderName & " " & mi.ReceivedTime ' <- uncomment this part if you need to debug (remember to open the "immediate" window also
' Look for attachments that contain ".xls" (this will also pick up ".xlsx" and ".xlsm" etc
If InStr(LCase(at.FileName), ".xls") > 0 Then
' Tell the script where to save the file and what details need to be appeneded to the file name to make it a unique name
at.SaveAsFile "\\xxxx\xxxxx\xxxxx\" & Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss") & at.FileName
Else
' literally do nothing (it's probably not needed but added just in case)
End If
Next at
End If
End If
Next i
UserForm1.Hide
CountNumberOfFiles
Sheet2.Cells(1, 1) = "Date last ran was"
Sheet2.Cells(1, 2) = Now()
errordetails:
Debug.Print "Error number: " & Err.Number _
& " " & Err.Description;
End Sub
Sub CountNumberOfFiles()
Dim FolderPath As String
Dim Path As String
Dim Count As Integer
FolderPath = "\\xxxx\xxxxxxx\xxxxxxxxx"
Path = FolderPath & "\*"
FileName = Dir(Path)
Do While FileName <> ""
Count = Count + 1
FileName = Dir()
Loop
MsgBox "Search completed. There are " & Count & " attachments extracted to the folder \\xxxxxx\xxxxxx\xxxx"
End Sub
In the Immediate window, the Debug.Print for this part does show all the correct dates and times but it says it finds nothing even when there is one item that definitely matches.
' Get the date last ran
If Sheet2.Cells(1, 2) <> "" Then
Sheet1.Cells(2, 2) = Sheet2.Cells(1, 2)
Debug.Print "Start Date is: "; Sheet1.Cells(2, 2)
Sheet1.Cells(2, 4) = Now()
Debug.Print "End Date is: "; Sheet1.Cells(2, 4)
Else
Sheet2.Cells(1, 2) = ""
Debug.Print Sheet1.Cells(2, 2)
End If
DateStart = Sheet1.Cells(2, 2) ' Cell B2
DateEnd = Sheet1.Cells(2, 4) ' Cell B4
DateToCheck = "[ReceivedTime] >= """ & DateStart & """ And [ReceivedTime] <= """ & DateEnd & """"
Debug.Print "Date to Check is: "; DateToCheck
' -- end of Date from and to initialising
Thank you in advance for any assistance provided.

Answer 1

Dates are DateTime, not Text, so create text expressions for the date values:
DateToCheck = "[ReceivedTime] >= #" & Format(DateStart, "yyyy\/mm\/dd") & "# And [ReceivedTime] <= #" & Format(DateEnd, "yyyy\/mm\/dd") & "#"
Addendum:
Looking up the docs (always highly recommended), it appears that criteria must be text:
Although dates and times are typically stored with a Date format, the
Find and Restrict methods require that the date and time be converted
to a string representation. To make sure that the date is formatted as
Outlook expects, use the Format function. The following example
creates a filter to find all contacts that have been modified after
January 15, 1999 at 3:30 P.M.
Example:
sFilter = "[LastModificationTime] > '" & Format("1/15/99 3:30pm", "ddddd h:nn AMPM") & "'"
So, I guess you filter should read:
DateToCheck = "[ReceivedTime] >= '" & Format(DateStart, "ddddd h:nn AMPM") & "' And [ReceivedTime] <= '" & Format(DateEnd, "ddddd h:nn AMPM") & "'"