If you have an appointment on let's say 30-11 at 11h00 to 12h00 it will only look at 11h00 and adds the 20 default time and inserts a appointment at 11h20 to 11h40 instead of 12h00 to 12h20.
Debug print info
dtTimeToCheck: 15:00:00
[Start] >= '2024-12-06 12:00 ' AND [End] <= '2024-12-07 12:00 '
Start of function loop.
argCheckDate....: 06-12-24 15:00:00
argCheckDate.....: 06-12-24 15:00:00
CheckAvailability: False
End of function loop.
Appointment time :06-12-24 at: 15:00:00
False
2024/12/06
dtTimeToCheck: 15:00:00
[Start] >= '2024-12-06 12:00 ' AND [End] <= '2024-12-07 12:00 '
Start of function loop.
argCheckDate....: 06-12-24 15:00:00
argCheckDate.....: 06-12-24 15:00:00
CheckAvailability: False
End of function loop.
Appointment time :06-12-24 at: 15:00:00
False
Have tried changing duration as long and even duration = DateAdd("n", duration, argChkTime) As well as suggestions by Nitton but wasn't unfortunately able to find a solution.
Option Explicit
' If already booked for that time (11h00 + 20 minutes) return true, and check 11h20 + 20...
Function testReverseDate()
Dim sDate As Date
Dim sTime As Date
Dim sEmail As String
Dim sName As String
Dim sLocation As String
Dim sRemark As String
sDate = "06-12-2024"
sDate = Format(sDate, "yyyy,mm,dd")
sTime = "15:00"
sName = "Just A Name"
sEmail = "anon@email.com"
sLocation = "My Location"
sRemark = "My Remark"
Debug.Print (sDate)
Call BlockNextFreeSlot(sDate, sName, sEmail, sLocation, sTime, sRemark)
End Function
Sub BlockNextFreeSlot(dtDateToCheck As Date, sName, _
sEmail, strLocation, sTime, sRemark)
' Set the minimum duration for a time slot to 30 minutes.
Dim min_Duration_for_slot
min_Duration_for_slot = 20 / (24 * 60)
' Get the end time for the work day from the UserForm.
Dim WorkendTime As Date
WorkendTime = "16:00"
' Get the duration of the appointment from the UserForm.
Dim TDuration As Date
TDuration = 20 / (24 * 60) ' Default duration is 20 minutes.
' If the appointment duration is less than the minimum slot duration, set it as the new minimum.
If TDuration < min_Duration_for_slot Then min_Duration_for_slot = TDuration
' Get the start time of the appointment from the UserForm.
Dim dtTimeToCheck As Date
dtTimeToCheck = Format(sTime, "hh:mm")
' Check if the time slot is already taken, and if so, find the next available time slot.
Dim SlotIsTaken As Boolean
SlotIsTaken = True
Do Until Not SlotIsTaken Or dtTimeToCheck > WorkendTime
SlotIsTaken = CheckAvailability(dtDateToCheck, dtTimeToCheck + TDuration, TDuration)
Debug.Print (SlotIsTaken)
Debug.Print (dtDateToCheck & " " & dtTimeToCheck & " " & dtTimeToCheck + TDuration)
If SlotIsTaken Then
' Set the start time to the next available time slot.
dtTimeToCheck = DateAdd("n", min_Duration_for_slot, dtTimeToCheck)
End If
Loop
If SlotIsTaken Then
'No slots open, search next day
dtTimeToCheck = DateAdd("n", min_Duration_for_slot, dtTimeToCheck)
Debug.Print ("Time to Check: " & dtTimeToCheck)
Debug.Print ("---------")
Debug.Print ("Date to Check: " & dtDateToCheck)
Debug.Print ("---------")
NextDaySlot = True
Call BlockNextFreeSlot(dtDateToCheck + 1, sName, sEmail, strLocation, sTime, sRemark)
Else
If dtTimeToCheck = sTime And NextDaySlot = False Then
If CreateAppointment(dtDateToCheck, dtTimeToCheck, sEmail, sName, strLocation, sRemark) Then
'Create appointement as requested on same day, at requested time
Debug.Print "Appointment time :" & dtDateToCheck & " at: " & dtTimeToCheck
End If
Else
'Create appointement but was resceduled slots taken, send email with rescedule
If CreateAppointment(dtDateToCheck, dtTimeToCheck, sEmail, sName, strLocation, sRemark) Then
Debug.Print "Appointment time :" & dtDateToCheck & " at: " & dtTimeToCheck
End If
Debug.Print dtTimeToCheck
End If
End If
Debug.Print ("if next day, send notification")
Debug.Print (NextDaySlot)
End Sub
Public Function CheckAvailability(ByVal argChkDate As Date, _
ByVal argChkTime As Date, ByVal duration As Date) As Boolean
' duration As Date ?
' Since Outlook constants used, code is in Outlook
' olFolderCalendar, olAppointment and olMeetingRequest
Dim oApptItem As AppointmentItem
Dim oFolder As Folder
Dim oMeetingoApptItem As MeetingItem
Dim oObject As Object
Dim ItemstoCheck As Items
Dim strRestriction As String
Dim FilteredItemstoCheck As Items
Dim argCheckDate As Date
Dim daStart As String
Dim daEnd As String
'Combine the date and time arguments
argCheckDate = argChkDate + argChkTime
duration = DateAdd("n", duration, argChkTime)
'Avoid past booking of calendar
If argCheckDate < Now Then
CheckAvailability = True
GoTo FUNCEXIT
End If
'Get the default calendar folder
Set oFolder = Session.GetDefaultFolder(olFolderCalendar)
'Get all items in the calendar folder
Set ItemstoCheck = oFolder.Items
'Include recurring appointments
ItemstoCheck.IncludeRecurrences = True
'Sort the items by start date
ItemstoCheck.Sort "[Start]"
'Filter the items by the given date range
' argCheckDate and hh:mm
daStart = Format(argCheckDate, "dd/mm/yyyy hh:mm AMPM")
daEnd = Format(argCheckDate + 1, "dd/mm/yyyy hh:mm AMPM")
' If US date format fails when day is less than 13
' DDDDD HH:NN
' yyyy-mm-dd hh:mm AM/PM
strRestriction = "[Start] >= '" & daStart & "' AND [End] <= '" & daEnd & "'"
Debug.Print (strRestriction)
Set FilteredItemstoCheck = ItemstoCheck.Restrict(strRestriction)
'Check if there is a conflicting appointment
CheckAvailability = False
For Each oObject In FilteredItemstoCheck
If (oObject.Start = argCheckDate) _
Or oObject.End = (argCheckDate + duration) _
Or (argCheckDate > oObject.Start And argCheckDate < oObject.End) _
Or DateAdd("n", duration, argCheckDate) > oObject.Start And DateAdd("n", duration, argCheckDate) < oObject.End _
Or oObject.Start > argCheckDate And oObject.Start < DateAdd("n", duration, argCheckDate) Then
CheckAvailability = True
Exit For
End If
Next oObject
Debug.Print
Debug.Print " argCheckDate.....: " & argCheckDate
Debug.Print " CheckAvailability: " & CheckAvailability
Debug.Print "End of function loop."
FUNCEXIT:
'Cleanup
Set oMeetingoApptItem = Nothing
Set oFolder = Nothing
Set oApptItem = Nothing
Set oObject = Nothing
End Function
I returned argChkDate to the filter.
Duration variables declared as Long not Date.
I broke the If statement into multiple parts to see what it did. You could apply DateAdd to the original single If.
Option Explicit
' If already booked for that time (11h00 + 20 minutes) return true, and check 11h20 + 20...
Sub testFreeslotCalender()
'Call BlockNextFreeSlot("30-11-2024", "Names", "anon@email.com", "Location", "11:00", "My Remark")
' Date format in a string is unreliable
' Test with d less than 13 and m <> d
Call BlockNextFreeSlot("2024-12-06", "Names", "anon@email.com", "Location", "11:00", "My Remark")
End Sub
Sub BlockNextFreeSlot(dtDateToCheck As Date, sName, sEmail, strLocation, sTime, sRemark)
' Set the minimum duration for a time slot to 30 minutes.
Dim min_Duration_for_slot As Long
min_Duration_for_slot = 30
' Get the end time for the work day from the UserForm.
Dim WorkendTime As Date
WorkendTime = "16:00"
Dim TDuration As Long
TDuration = 20
' If the appointment duration is less than the minimum slot duration, set it as the new minimum.
If TDuration < min_Duration_for_slot Then min_Duration_for_slot = TDuration
' Get the start time of the appointment from the UserForm.
Dim dtTimeToCheck As Date
dtTimeToCheck = Format(sTime, "hh:mm")
Debug.Print " dtTimeToCheck: " & dtTimeToCheck
' Check if the time slot is already taken, and if so, find the next available time slot.
Dim SlotIsTaken As Boolean
SlotIsTaken = True
Do Until Not SlotIsTaken Or dtTimeToCheck > WorkendTime
Debug.Print " dtTimeToCheck: " & dtTimeToCheck
SlotIsTaken = CheckAvailability(dtDateToCheck, dtTimeToCheck, TDuration)
Debug.Print " SlotIsTaken: " & SlotIsTaken
If SlotIsTaken Then
' Set the start time to the next available time slot.
dtTimeToCheck = DateAdd("n", min_Duration_for_slot, dtTimeToCheck)
Debug.Print " dtTimeToCheck: " & dtTimeToCheck
End If
Loop
If SlotIsTaken Then
Debug.Print ("....Busy")
Else
Debug.Print ("Creating an appointement")
Debug.Print dtTimeToCheck
End If
End Sub
Public Function CheckAvailability(ByVal argChkDate As Date, _
ByVal argChkTime As Date, ByVal duration As Long) As Boolean
Dim oFolder As folder
Dim oObject As Object
Dim ItemstoCheck As Items
Dim strRestriction As String
Dim FilteredItemstoCheck As Items
Dim argCheckDate As Date
Dim daStart As String
Dim daEnd As String
'Combine the date and time arguments
argCheckDate = argChkDate + argChkTime
'Avoid past booking of calendar
If argCheckDate < Now Then
CheckAvailability = True
GoTo FUNCEXIT
End If
'Get the default calendar folder
Set oFolder = Session.GetDefaultFolder(olFolderCalendar)
'Get all items in the calendar folder
Set ItemstoCheck = oFolder.Items
'Include recurring appointments
ItemstoCheck.IncludeRecurrences = True
'Sort the items by start date
ItemstoCheck.Sort "[Start]"
'Filter the items for given day
' Note: returned to argChkDate
daStart = Format(argChkDate, "yyyy/mm/dd hh:mm AMPM")
daEnd = Format(argChkDate + 1, "yyyy/mm/dd hh:mm AMPM")
strRestriction = "[Start] >= '" & daStart & "' AND [End] <= '" & daEnd & "'"
Debug.Print strRestriction
Set FilteredItemstoCheck = ItemstoCheck.Restrict(strRestriction)
'Check if there is a conflicting appointment
CheckAvailability = False
Debug.Print
Debug.Print "Start of function loop."
Debug.Print " argCheckDate....: " & argCheckDate
For Each oObject In FilteredItemstoCheck
If oObject.Start = argCheckDate Then
Debug.Print " oObject.Start...: " & oObject.Start
Debug.Print " argCheckDate....: " & argCheckDate
CheckAvailability = True
Debug.Print "Condition 1"
Exit For
End If
If oObject.End = (argCheckDate + duration) Then
CheckAvailability = True
Debug.Print "Condition 2"
Exit For
End If
If argCheckDate > oObject.Start Then
Debug.Print " oObject.Start...: " & oObject.Start
Debug.Print " argCheckDate....: " & argCheckDate
If argCheckDate < oObject.End Then
Debug.Print " oObject.End.....: " & oObject.End
Debug.Print " argCheckDate....: " & argCheckDate
CheckAvailability = True
Debug.Print "Condition 3"
Exit For
End If
End If
If DateAdd("n", duration, argCheckDate) > oObject.Start Then
Debug.Print " (argCheckDate + duration): " & (argCheckDate + duration)
Debug.Print " oObject.Start...: " & oObject.Start
If DateAdd("n", duration, argCheckDate) < oObject.End Then
CheckAvailability = True
Debug.Print "Condition 4"
Exit For
End If
End If
If oObject.Start > argCheckDate Then
If oObject.Start < DateAdd("n", duration, argCheckDate) Then
CheckAvailability = True
Debug.Print "Condition 5"
Exit For
End If
End If
Next oObject
Debug.Print
Debug.Print " argCheckDate.....: " & argCheckDate
Debug.Print " CheckAvailability: " & CheckAvailability
Debug.Print "End of function loop."
FUNCEXIT:
'Cleanup
Set oFolder = Nothing
Set oObject = Nothing
End Function
Apparently the manipulated string is not recognized as a date.
' If already booked for that time (11h00 + 20 minutes) return true, and check 11h20 + 20...
Sub testFreeslotCalender_CDate()
'Call BlockNextFreeSlot("30-11-2024", "Names", "anon@email.com", "Location", "11:00", "My Remark")
' Date format in a string is unreliable
' Test with d less than 13 and m <> d
Dim sDate As String
sDate = "06-12-2024"
sDate = Split(sDate, "-")(2) & "/" & Split(sDate, "-")(1) & "/" & Split(sDate, "-")(0)
Call BlockNextFreeSlot(CDate(sDate), "Names", "anon@email.com", "Location", "11:00", "My Remark")
End Sub