Searching Outlook calendar for appointments through VBA

I’d like to search for free appointment spaces in my outlook calendar and save the closest 2 x 1 hour slots that land on different days. It’s working apart from I'm struggling to get a result on the current day - if I'm busy all day until AFTER the current time, but there is still space left for the remainder of the day, then it returns an answer.

When there were free appointments earlier in the day, prior to the current time, (and also free appointments later than the current time) then it doesn't like it and will just return 'no appointments found' (for the current day only)

I've put in a debug but it seems to 'give up' at about 11.30am before I presume Typename(olappt) equals nothing so moves on... Can anyone help me figure this out please?

Relevant bit:

                    With OLAppts
         ' capture start time and duration of each item
        Set OLAppt = .GetFirst

        Do While TypeName(OLAppt) <> "Nothing"
             ' find first free timeslot
            Select Case DateValue(dtmAppt)
            Case DateValue(Format(OLAppt.Start, "dd/mm/yyyy"))
            Debug.Print DateValue(Format(OLAppt.Start, "dd/mm/yyyy"))
            Debug.Print Format(OLAppt.Start, "Hh:Nn")
                
                    If Format(dtmNext, "Hh:Nn") < Format(OLAppt.Start, "Hh:Nn") Then

                         ' find gap before next appointment starts
                        If Format(OLAppt.Start, "Hh:Nn") < Format(dtmLastAppt, "Hh:Nn") Then
                            intDuration = DateDiff("n", dtmNext, Format(OLAppt.Start, "Hh:Nn"))
                        Else
                            intDuration = DateDiff("n", dtmNext, Format(dtmLastAppt, "Hh:Nn"))
                        End If

                         ' can we fit an appointment into the gap?
                        If intDuration >= intDefaultAppt Then
                    strList = strList & Format(dtmNext, "Hh:Nn ampm") & ";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & ";"
                    End If


            End If

             ' find first available time after appointment
            dtmNext = DateAdd("n", OLAppt.Duration + intDuration, _
            dtmNext)

             ' don't go beyond last possible appointment time
            If dtmNext > dtmLastAppt Then
                Exit Do
            End If
        End Select

        intDuration = 0

        Set OLAppt = .GetNext
        If dtmNext > dtmLastAppt Then
        Exit Do
    End If
'Debug.Print OLAppt = .Count

    Loop
End With

All the code of this element in case it's needed:

Option Explicit
Function FindFreeTime(dtmAppt As Date, dtmFirstAppt As Date, dtmLastAppt As Date, intDefaultAppt As Integer, i As Integer) As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose:      Capture all available timeslots (between appointments) on
'               nominated day
'
' Inputs:       dtmAppt         Date to search
'
' Assumptions:  * Free timeslot must be >= default appointment time
'               * Free timeslot must be between default start and end times for
'                 appointments
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim objOL As New Outlook.Application ' Outlook
Dim objNS As Namespace ' Namespace
Dim OLFldr As Outlook.MAPIFolder ' Calendar folder
Dim OLAppt As Object ' Single appointment
Dim OLAppts As Outlook.Items ' Appointment collection
Dim strDay As String ' Day for appointment
Dim strList As String ' List of all available timeslots
Dim dtmNext As Date ' Next available time
Dim intDuration As Integer ' Duration of free timeslot
Const C_Procedure = "FindFreeTime" ' Procedure name
dtmNext = dtmFirstAppt
If i = 0 And dtmFirstAppt < Now Then
dtmNext = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
End If
On Error GoTo ErrHandler
' list box column headings
'   strList = "Start Time;End Time;"
' get full span of selected day
strDay = "[Start] >= '" & dtmAppt & "' and " & "[Start] < '" & dtmAppt & " 11:59 pm'"
Set objNS = objOL.GetNamespace("MAPI")
' Get the local calendar folder
Set OLFldr = objNS.GetDefaultFolder(olFolderCalendar)
' Get the appointments for the selected day
Set OLAppts = OLFldr.Items.Restrict(strDay)
'  dtmNext = C_dtmFirstAppt
' Sort the collection (required by IncludeRecurrences)
OLAppts.Sort "[Start]"
' Make sure recurring appointments are included
OLAppts.IncludeRecurrences = True
With OLAppts
' capture start time and duration of each item
Set OLAppt = .GetFirst
Do While TypeName(OLAppt) <> "Nothing"
' find first free timeslot
Select Case DateValue(dtmAppt)
Case DateValue(Format(OLAppt.Start, "dd/mm/yyyy"))
Debug.Print Format(OLAppt.Start, "Hh:Nn")
If Format(dtmNext, "Hh:Nn") < Format(OLAppt.Start, "Hh:Nn") Then
' find gap before next appointment starts
If Format(OLAppt.Start, "Hh:Nn") < Format(dtmLastAppt, "Hh:Nn") Then
intDuration = DateDiff("n", dtmNext, Format(OLAppt.Start, "Hh:Nn"))
Else
intDuration = DateDiff("n", dtmNext, Format(dtmLastAppt, "Hh:Nn"))
End If
' can we fit an appointment into the gap?
If intDuration >= intDefaultAppt Then
strList = strList & Format(dtmNext, "Hh:Nn ampm") & ";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & ";"
End If
End If
' find first available time after appointment
dtmNext = DateAdd("n", OLAppt.Duration + intDuration, _
dtmNext)
' don't go beyond last possible appointment time
If dtmNext > dtmLastAppt Then
Exit Do
End If
End Select
intDuration = 0
Set OLAppt = .GetNext
If dtmNext > dtmLastAppt Then
Exit Do
End If
'Debug.Print OLAppt = .Count
Loop
End With
' capture remainder of day
intDuration = DateDiff("n", dtmNext, Format(dtmLastAppt, "Hh:Nn"))
If intDuration >= intDefaultAppt Then
strList = strList & Format(dtmNext, "Hh:Nn ampm") & _
";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & _
";"
End If
FindFreeTime = strList
ExitHere:
'On Error Resume Next
Set OLAppt = Nothing
Set OLAppts = Nothing
Set objNS = Nothing
Set objOL = Nothing
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & C_Procedure & vbCrLf & Err.Description
Resume ExitHere
End Function
Sub ScheduleAppointments()
Dim dtmFirstAppt As Date
Dim dtmLastAppt As Date
Dim intDefaultAppt As Integer
' Set the default values for appointment times and duration
dtmFirstAppt = #9:00:00 AM#
dtmLastAppt = #8:00:00 PM#
intDefaultAppt = 60 ' in minutes
' Call the function to find and schedule appointments
ScheduleFreeTimeAppointments dtmFirstAppt, dtmLastAppt, intDefaultAppt
End Sub
Function ScheduleOutlookAppointment(dtmStart As Date, dtmEnd As Date) As Boolean
' Create a new appointment in the default calendar folder
On Error Resume Next 'to handle error if Outlook is not open
Dim objOL As New Outlook.Application
Dim objNS As Namespace
Dim objAppt As AppointmentItem
Set objNS = objOL.GetNamespace("MAPI")
Set objAppt = objNS.GetDefaultFolder(olFolderCalendar).Items.Add(olAppointmentItem)
With objAppt
.Subject = "Scheduled appointment"
.Start = dtmStart
.End = dtmEnd
.Save
End With
ScheduleOutlookAppointment = (Err.Number = 0) ' return True if no error occurred, False otherwise
Err.Clear
End Function
Sub ScheduleFreeTimeAppointments(ByVal dtmFirstAppt As Date, ByVal dtmLastAppt As Date, ByVal intDefaultAppt As Integer)
Dim strList     As String
Dim dtmAppt     As Date
Dim i           As Integer
Dim found       As Integer
Dim intCount    As Integer
Dim dtmLastScheduled As Date
' Check if the first day should be skipped
dtmAppt = Date
If TimeValue(Now) > dtmLastAppt Then
dtmAppt = DateAdd("d", 1, Date)
End If
For i = 0 To 13
If i = 0 Then        ' First day
If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmFirstAppt Then
' Current time is after dtmFirstAppt, so set dtmFirstAppt to the next whole hour
dtmFirstAppt = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
Dim durDefaultAppt As Double
Dim timeDefaultAppt As Date
timeDefaultAppt = TimeValue(dtmFirstAppt)        ' Convert it into the time of day only.
'Calculate the end of the appoint
Dim timeEndAppt As Date
timeEndAppt = DateAdd("n", intDefaultAppt, timeDefaultAppt)
'Check if the end of the appointment is equal to or greater than the time of logging off.
If timeEndAppt >= dtmLastAppt Then
'if so then move on to the next day.
i = 1
'otherwise carry on
End If
End If
Else        ' All other days
dtmFirstAppt = #9:00:00 AM#
End If
If i > 0 Then
dtmAppt = DateAdd("d", 1, dtmAppt)
End If
If Weekday(dtmAppt) >= 2 And Weekday(dtmAppt) <= 6 Then        ' Check if the date is a weekday
strList = FindFreeTime(dtmAppt, dtmFirstAppt, dtmLastAppt, intDefaultAppt, i)
If Len(strList) > 0 Then        ' A free timeslot was found
Debug.Print "Free timeslots found For " & Format(dtmAppt, "dd/mm/yyyy") & ":"
Debug.Print strList
Dim arrSlots()  As String
Dim j           As Integer
Dim dtmStart    As Date
Dim dtmEnd      As Date
' Schedule appointments for the free slots
arrSlots = Split(strList, ";")
For j = 0 To UBound(arrSlots) - 1 Step 2
dtmStart = CDate(dtmAppt & " " & arrSlots(j))
dtmEnd = CDate(dtmAppt & " " & arrSlots(j + 1))
' Check if the appointment is within the next two weeks
If dtmStart >= Now() And dtmStart <= DateAdd("d", 14, Now()) Then
If dtmStart >= DateAdd("d", 1, dtmLastScheduled) Then        ' Schedule appointment only if it's on a different day than the last scheduled appointment
If ScheduleOutlookAppointment(dtmStart, DateAdd("n", intDefaultAppt, dtmStart)) Then        ' Set the appointment duration to intDefaultAppt
intCount = intCount + 1
dtmLastScheduled = dtmStart        ' Update the date of the last scheduled appointment
' Stop scheduling appointments once we've scheduled two
If intCount = 2 Then
Exit For
End If
Else
Debug.Print "Error scheduling appointment For " & dtmStart
End If
End If
End If
Next j
found = found + 1
Else
Debug.Print "No free timeslots found For " & Format(dtmAppt, "dd/mm/yyyy")
End If
Else
Debug.Print "Skipping weekend day " & Format(dtmAppt, "dd/mm/yyyy")
End If
' Exit the loop if we've scheduled two appointments
If intCount = 2 Then
Exit For
End If
Next i
' Notify the user if no appointments were scheduled
If intCount = 0 Then
MsgBox "No available time slots found within the Next two weeks.", vbInformation
Else
MsgBox intCount & " appointment(s) scheduled.", vbInformation
End If
End Sub
``` GB
</details>
# 答案1
**得分**: 1
我在下面给出的答案是错误的！
代码中有很多问题，但总体上我的过滤器在第一天出了问题。
如果 i = 0（即如果我在当前天），则过滤器现在从当前时间之后开始搜索。如果 i 不等于 0，则整天都可以查看（过程将确定它是否适合我愿意提供的时间段）。
与此相关的部分在这里：
```VBA
dtmNext = dtmFirstAppt
If i = 0 And dtmFirstAppt &lt; Now Then
dtmNext = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
End If
On Error GoTo ErrHandler
If i = 0 Then
&#39; 获取当前时间
Dim currentTime As Date
currentTime = Now()
&#39; 使用当前时间作为搜索的开始时间
strDay = &quot;[Start] &gt;= &#39;&quot; &amp; Format(dtmAppt, &quot;Short Date&quot;) &amp; &quot; &quot; &amp; Format(dtmNext, &quot;hh:nn&quot;) &amp; &quot;&#39; And ([End] &lt;= &#39;&quot; &amp; dtmAppt &amp; &quot; 11:59 pm&#39; Or [AllDayEvent] = True)&quot;
Else
&#39; 使用默认的开始和结束时间进行搜索
strDay = &quot;[Start] &gt;= &#39;&quot; &amp; dtmAppt &amp; &quot;&#39; And ([End] &lt;= &#39;&quot; &amp; dtmAppt &amp; &quot; 11:59 pm&#39; Or [AllDayEvent] = True)&quot;
End If

我之前认为问题所在的地方没有改变。

我还不得不在我的日历中设置一个临时约会，从下一个整点开始的一个小时的约会 - 因为如果你的日历中没有剩余的约会，对于当前的一天，那么代码将不会考虑今天作为一个选项（因为它将在过程中失败if语句 - 下面

If dtmStart >= Now() And DateDiff("n", Now(), dtmStart) >= 60 And dtmStart <= DateAdd("d", 14, Now()) Then

它仍然失败，因为我认为过滤器将说明我从哪个时间点开始是空闲的。如果我上次空闲的时间是在过去，那么if语句就会失败。这个过滤器：

strDay = "[Start] >= '" & Format(dtmAppt, "Short Date") & " " & Format(dtmNext, "hh:nn") & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"

不会返回“当天晚些时候的空闲约会”。与其强迫它预订一个时间并假设我是空闲的（而且我已经花了太长时间在这上面了！），我决定插入一个临时约会，以便我总是至少有一个约会，以便代码会说明我今天晚些时候是空闲的。
另外，'AllDayEvent'过滤器现在正在工作。由于某种原因，我在使其工作时遇到了困难；然而，正确的编写方式是...

[AllDayEvent] = True)"

无论如何，我还包括了加载一封电子邮件给客户提供会议（带有一些额外的代码以帮助更快地定制电子邮件）。
以防有人将来想要使用此元素的完整代码如下：

Option Explicit
Dim arrAppointments(1 To 2, 1 To 2) As Variant
Function FindFreeTime(dtmAppt As Date, dtmFirstAppt As Date, dtmLastAppt As Date, intDefaultAppt As Integer, i As Integer) As String
Dim objOL As New Outlook.Application ' Outlook
Dim objNS As Namespace ' Namespace
Dim OLFldr As Outlook.MAPIFolder ' Calendar folder
Dim olAppt As Object ' Single appointment
Dim OLAppts As Outlook.Items ' Appointment collection
Dim strDay As String ' Day for appointment
Dim strList As String ' List of all available timeslots
Dim dtmNext As Date ' Next available time
Dim intDuration As Integer ' Duration of free timeslot
Const C_Procedure = "FindFreeTime" ' Procedure name
dtmNext = dtmFirstAppt
If i = 0 And dtmFirstAppt < Now Then
dtmNext = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
End If
On Error GoTo ErrHandler
If i = 0 Then
' Get the current time of day
Dim currentTime As Date
currentTime = Now()
' Use the current time of day as the start time for the search
strDay = "[Start] >= '" & Format(dtmAppt, "Short Date") & " " & Format(dtmNext, "hh:nn") & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"
Else
' Use the default start and end times for the search
strDay = "[Start] >= '" & dtmAppt & "' And ([End] <= '&quot
<details>
<summary>英文:</summary>
The answer I gave below was wrong!
There was quite a bit wrong with the code but in the main my filter was wrong for the first day. 
If i = 0 (i.e. if I&#39;m on the current day), the filter now starts searching from after the current time of day. If i isn&#39;t 0 then the whole day is open to look at (the procedure will determine if it fits inside of the times I&#39;m willing to offer).
The relevant bit for that is here:

dtmNext = dtmFirstAppt

If i = 0 And dtmFirstAppt < Now Then
dtmNext = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
End If
On Error GoTo ErrHandler

If i = 0 Then
' Get the current time of day
Dim currentTime As Date
currentTime = Now()

' Use the current time of day as the start time for the search
strDay = "[Start] >= '" & Format(dtmAppt, "Short Date") & " " & Format(dtmNext, "hh:nn") & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"

Else
' Use the default start and end times for the search
strDay = "[Start] >= '" & dtmAppt & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"
End If

No changes to where I first thought the issue was.
I've had to also set (in the code) a temporary appointment in my diary with an hours appointment from the next whole hour - as if you don't have any remaining appointments in your diary, for the current day, then the code will dismiss today as an option (because it will fail the if statement in the procedure - below

If dtmStart >= Now() And DateDiff("n", Now(), dtmStart) >= 60 And dtmStart <= DateAdd("d", 14, Now()) Then

It still fails this because I think the filter will state from which point of time I am free from. If the last time I was free was in the past, then the if statement will fail. This filter:

strDay = "[Start] >= '" & Format(dtmAppt, "Short Date") & " " & Format(dtmNext, "hh:nn") & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"

won’t return “free appointments” later in the day. Rather than forcing it to book in a time and assume I’m free (+ I’ve spent too long on this already!), I decided to push in a temporary appointment so that I will always have at least one appointment for the code to state that I’m free later in the day.
In addition, the ‘AllDayEvent’ filter is now working. For some reason I was having difficulty making this work; however the correct way of writing it is … 
‘’’
…[AllDayEvent] = True)"
‘’’
Anyway, I've also included loading an email to the client offering a meeting (with some extra code to help with customise the email a little quicker).
The full code for this element in case someone wants to use it in the future is as follows:

Option Explicit

Dim arrAppointments(1 To 2, 1 To 2) As Variant

Function FindFreeTime(dtmAppt As Date, dtmFirstAppt As Date, dtmLastAppt As Date, intDefaultAppt As Integer, i As Integer) As String

Dim objOL As New Outlook.Application ' Outlook
Dim objNS As Namespace ' Namespace
Dim OLFldr As Outlook.MAPIFolder ' Calendar folder
Dim olAppt As Object ' Single appointment
Dim OLAppts As Outlook.Items ' Appointment collection
Dim strDay As String ' Day for appointment
Dim strList As String ' List of all available timeslots
Dim dtmNext As Date ' Next available time
Dim intDuration As Integer ' Duration of free timeslot
Const C_Procedure = "FindFreeTime" ' Procedure name
dtmNext = dtmFirstAppt
If i = 0 And dtmFirstAppt < Now Then
dtmNext = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
End If
On Error GoTo ErrHandler

If i = 0 Then
' Get the current time of day
Dim currentTime As Date
currentTime = Now()

' Use the current time of day as the start time for the search
strDay = "[Start] >= '" & Format(dtmAppt, "Short Date") & " " & Format(dtmNext, "hh:nn") & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"

Else
' Use the default start and end times for the search
strDay = "[Start] >= '" & dtmAppt & "' And ([End] <= '" & dtmAppt & " 11:59 pm' Or [AllDayEvent] = True)"
End If

Set objNS = objOL.GetNamespace("MAPI")
' Get the local calendar folder
Set OLFldr = objNS.GetDefaultFolder(olFolderCalendar)
' Get the appointments for the selected day
Set OLAppts = OLFldr.Items.Restrict(strDay)
' Sort the collection (required by IncludeRecurrences)
OLAppts.Sort "[Start]"
' Make sure recurring appointments are included
OLAppts.IncludeRecurrences = True
With OLAppts
' capture start time and duration of each item
Set olAppt = .GetFirst
Do While TypeName(olAppt) <> "Nothing"
' find first free timeslot
Select Case DateValue(dtmAppt)
Case DateValue(Format(olAppt.Start, "dd/mm/yyyy"))
'  Debug.Print Format(olAppt.Start, "Hh:Nn")
If Format(dtmNext, "Hh:Nn") < Format(olAppt.Start, "Hh:Nn") Then
' find gap before next appointment starts
If Format(olAppt.Start, "Hh:Nn") < Format(dtmLastAppt, "Hh:Nn") Then
intDuration = DateDiff("n", dtmNext, Format(olAppt.Start, "Hh:Nn"))
Else
intDuration = DateDiff("n", dtmNext, Format(dtmLastAppt, "Hh:Nn"))
End If
' can we fit an appointment into the gap?
If intDuration >= intDefaultAppt Then
strList = strList & Format(dtmNext, "Hh:Nn ampm") & ";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & ";"
End If
End If
' find first available time after appointment
dtmNext = DateAdd("n", olAppt.Duration + intDuration, _
dtmNext)
' don't go beyond last possible appointment time
If dtmNext > dtmLastAppt Then
Exit Do
End If
End Select
intDuration = 0
Set olAppt = .GetNext
If dtmNext > dtmLastAppt Then
Exit Do
End If
Loop

End With

' capture remainder of day
intDuration = DateDiff("n", dtmNext, Format(dtmLastAppt, "Hh:Nn"))

If intDuration >= intDefaultAppt Then
strList = strList & Format(dtmNext, "Hh:Nn ampm") & _
";" & Format(DateAdd("n", intDuration, dtmNext), "Hh:Nn ampm") & _
";"
End If

FindFreeTime = strList

ExitHere:
Set olAppt = Nothing
Set OLAppts = Nothing
Set objNS = Nothing
Set objOL = Nothing
Exit Function

ErrHandler:
MsgBox Err.Number & ": " & C_Procedure & vbCrLf & Err.Description
Resume ExitHere
End Function

Sub ScheduleAppointments()
Dim dtmFirstAppt As Date
Dim dtmLastAppt As Date
Dim intDefaultAppt As Integer

' Set the default values for appointment times and duration
dtmFirstAppt = #8:00:00 AM#
dtmLastAppt = #7:00:00 PM#
intDefaultAppt = 30 ' in minutes
' Call the function to find and schedule appointments
ScheduleFreeTimeAppointments dtmFirstAppt, dtmLastAppt, intDefaultAppt

End Sub

Function ScheduleOutlookAppointment(dtmStart As Date, dtmEnd As Date) As Boolean
' Create a new appointment in the default calendar folder
On Error Resume Next 'to handle error if Outlook is not open
Dim objOL As New Outlook.Application
Dim objNS As Namespace
Dim objAppt As AppointmentItem

Set objNS = objOL.GetNamespace("MAPI")
Set objAppt = objNS.GetDefaultFolder(olFolderCalendar).Items.Add(olAppointmentItem)
With objAppt
.Subject = "Scheduled appointment"
.Start = dtmStart
.End = dtmEnd
.Save
End With
ScheduleOutlookAppointment = (Err.Number = 0) ' return True if no error occurred, False otherwise
Err.Clear

End Function

Sub SendInitialEmail(ByVal clientName As String, ByVal colleagueName As String, ByVal manualDate As Date, ByVal appointmentDate1 As String, ByVal appointmentTime1 As Date, ByVal appointmentDate2 As String, ByVal appointmentTime2 As Date)
' Create a new Outlook email message
Dim objOL As New Outlook.Application
Dim objMail As Outlook.MailItem
Set objMail = objOL.CreateItem(olMailItem)
With objMail
.Subject = "Initial Summary and Next Steps"
.To = "<client email address>"
.HTMLBody = "Hello " & clientName & ",<br><br>" _
& "email contents..."

If Not appointmentDate1 = "" Then ' check if appointmentDate1 is not empty
Dim appointment1Date As Date ' declare a variable to store the date portion of appointmentDate1
appointment1Date = DateValue(Left(appointmentDate1, 10)) ' extract the first 10 characters from appointmentDate1 and convert to a Date type

Dim appointment1Description As String   ' declare a variable to store the description of the appointment time slot
If appointment1Date = Date Then    ' check if appointment1Date is today's date
appointment1Description = "today"   ' set the description to "today"
ElseIf appointment1Date = Date + 1 Then   ' check if appointment1Date is tomorrow's date
appointment1Description = "tomorrow, " & Format(appointment1Date, "dddd dd mmmm")   ' set the description to "tomorrow" followed by the formatted date
Else
appointment1Description = Format(appointment1Date, "dddd dd mmmm")   ' set the description to the formatted date
End If
Dim appointment2Description As String   ' declare a variable to store the description of the second appointment time slot
If Not appointmentDate2 = "" Then   ' check if appointmentDate2 is not equal to the default date value
Dim appointment2Date As Date   ' declare a variable to store the date portion of appointmentDate1
appointment2Date = DateValue(Left(appointmentDate2, 10))   ' extract the first 10 characters from appointmentDate1 and convert to a Date type
If appointment2Date = Date + 1 Then   ' check if appointmentDate2 is tomorrow's date
appointment2Description = "tomorrow, " & Format(appointmentDate2, "dddd dd mmmm")   ' set the description to "tomorrow" followed by the formatted date
Else
appointment2Description = Format(appointmentDate2, "dddd dd mmmm")   ' set the description to the formatted date
End If
.HTMLBody = .HTMLBody & "I'm currently free for a chat on " & appointment1Description & ", at " & Format(appointmentTime1, "h:mm AMPM") & ", or " & appointment2Description & ", at " & Format(appointmentTime2, "h:mm AMPM") & ". Do any of these times work with you?<br><br>"
' add the appointment slots to the email body, formatted with the time in 12-hour clock format with AM/PM indicator
Else
.HTMLBody = .HTMLBody & "I'm currently free for a chat " & appointment1Description & " at " & Format(CDate(appointmentDate1), "h:mm AMPM") & ". Does this work with you?<br><br>"
' add the first appointment slot to the email body, formatted with the time in 12-hour clock format with AM/PM indicator, and the second appointment slot set to a specific date and time
End If

Else
.HTMLBody = .HTMLBody & "Unfortunately, I couldn't find any available time slots within the next two weeks. <br><br>"
End If

.HTMLBody = .HTMLBody & "Kind regards, <br><br>" _
& "Ed"

.Display
' finish formatting the email body, adding the signature, and display the email in Outlook for the user to send.
End With

Set objMail = Nothing
Set objOL = Nothing
End Sub

Sub ScheduleFreeTimeAppointments(ByVal dtmFirstAppt As Date, ByVal dtmLastAppt As Date, ByVal intDefaultAppt As Integer)
Dim strList As String
Dim dtmAppt As Date
Dim i As Integer
Dim found As Integer
Dim intCount As Integer
Dim dtmLastScheduled As Date

Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
' Create a temporary appointment starting from the next whole hour
Dim dtmStart As Date
Dim dtmEnd As Date
dtmStart = Date + TimeSerial(Hour(Now), Application.WorksheetFunction.Ceiling(Minute(Now), 60), 0)
dtmEnd = DateAdd("n", 60, dtmStart)
Dim olApt As Outlook.AppointmentItem
Set olApt = olApp.CreateItem(olAppointmentItem)
olApt.Start = dtmStart
olApt.End = dtmEnd
olApt.Subject = "Temporary Appointment"
olApt.Save
' Check if the first day should be skipped
dtmAppt = Date
If TimeValue(Now) > dtmLastAppt Then
dtmAppt = DateAdd("d", 1, Date)
End If
For i = 0 To 13
If i = 0 Then        ' First day
' If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmFirstAppt Then
If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmLastAppt Then
' Current time is after dtmFirstAppt, so set dtmFirstAppt to the next whole hour
dtmFirstAppt = TimeValue(Date + TimeSerial(Hour(Time) + 1, 0, 0))
Dim durDefaultAppt As Double
Dim timeDefaultAppt As Date
timeDefaultAppt = TimeValue(dtmFirstAppt)        ' Convert it into the time of day only.
'Calculate the end of the appoint
Dim timeEndAppt As Date
timeEndAppt = DateAdd("n", intDefaultAppt, timeDefaultAppt)
'Check if the end of the appointment is equal to or greater than the time of logging off.
If timeEndAppt >= dtmLastAppt Then
'if so then move on to the next day.
i = 1
'otherwise carry on
End If
End If
Else        ' All other days
dtmFirstAppt = #8:00:00 AM#
End If
If i > 0 Then
dtmAppt = DateAdd("d", 1, dtmAppt)
End If
If Weekday(dtmAppt) >= 2 And Weekday(dtmAppt) <= 6 Then        ' Check if the date is a weekday
strList = FindFreeTime(dtmAppt, dtmFirstAppt, dtmLastAppt, intDefaultAppt, i)
If Len(strList) > 0 Then        ' A free timeslot was found
Dim arrSlots()  As String
Dim j           As Integer
' Schedule appointments for the free slots
arrSlots = Split(strList, ";")
For j = 0 To UBound(arrSlots) - 1 Step 2
dtmStart = CDate(dtmAppt & " " & arrSlots(j))
dtmEnd = CDate(dtmAppt & " " & arrSlots(j + 1))
' Check if the appointment is within the next two weeks
'  If dtmStart >= Now() And dtmStart <= DateAdd("d", 14, Now()) Then
If dtmStart >= Now() And DateDiff("n", Now(), dtmStart) >= 60 And dtmStart <= DateAdd("d", 14, Now()) Then
If DateValue(dtmStart) >= DateAdd("d", 1, DateValue(dtmLastScheduled)) Then
'  If dtmStart >= DateAdd("d", 1, dtmLastScheduled) Then        ' Schedule appointment only if it's on a different day than the last scheduled appointment
If ScheduleOutlookAppointment(dtmStart, DateAdd("n", intDefaultAppt, dtmStart)) Then        ' Set the appointment duration to intDefaultAppt
intCount = intCount + 1
arrAppointments(intCount, 1) = dtmStart ' Store the date of the appointment
Debug.Print dtmStart
Debug.Print arrAppointments(1, 1)
Debug.Print arrAppointments(2, 1)
arrAppointments(intCount, 2) = intDefaultAppt ' Store the duration of the appointment
dtmLastScheduled = dtmStart        ' Update the date of the last scheduled appointment
' Stop scheduling appointments once we've scheduled two
If intCount = 2 Then
Exit For
End If
Else
Debug.Print "Error scheduling appointment For " & dtmStart
End If
End If
End If
Next j

found = found + 1
Else
' Debug.Print "No free timeslots found For " & Format(dtmAppt, "dd/mm/yyyy")
End If
Else
' Debug.Print "Skipping weekend day " & Format(dtmAppt, "dd/mm/yyyy")
End If

' Exit the loop if we've scheduled two appointments
If intCount = 2 Then
Exit For
End If
Next i

If intCount = 0 Then
SendInitialEmail "John", "Sarah", DateSerial(2023, 3, 6), #1/1/4501#, "", #1/1/4501#, ""
ElseIf intCount = 1 Then
SendInitialEmail "John", "Sarah", DateSerial(2023, 3, 6), arrAppointments(1, 1), Format(arrAppointments(1, 1), "h:mm AM/PM"), #1/1/4501#, ""
ElseIf intCount = 2 Then
SendInitialEmail "John", "Sarah", DateSerial(2023, 3, 6), arrAppointments(1, 1), Format(arrAppointments(1, 1), "h:mm AM/PM"), arrAppointments(2, 1), Format(arrAppointments(2, 1), "h:mm AM/PM")
End If

If intCount = 0 Then
MsgBox "No available time slots found within the next two weeks.", vbInformation
Else
'MsgBox intCount & " appointment(s) scheduled.", vbInformation
End If

olApt.Delete
Set olApt = Nothing
Set olApp = Nothing

End Sub

<s>Actually I think I've fixed it. Quite simple in the end - 
I've modified the condition to check if the current time is later than the dtmLastAppt instead of dtmFirstAppt. This ensures that the code skips the current day only if all appointment slots for the day have already passed.
Changed from:

If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmFirstAppt Then

To:

If DateValue(Now) = dtmAppt And TimeValue(Now) > dtmLastAppt Then

I'm keeping this post up as there is very little documentation online of how to find free appointments in your Outlook calendar using the restrict method.</s>
</details>