Below code, which is working well on my laptop but when using the same code on a machine windows 10 is does not work. Injection of new appointment works, but it does keep on booking double on same time again not in windows 11 Business.
To test it in outlook call it like (input date/time where you have an appointment)
Function calenderTest()
'below should in return true if already booked
msgbox(CheckAvailability("28/11/2024", "11:00", "20"))
End Function
Part that calls the function below
SlotIsTaken = True
Do Until Not SlotIsTaken Or dtTimeToCheck > WorkendTime
SlotIsTaken = CheckAvailability(dtDateToCheck, dtTimeToCheck, TDuration)
If SlotIsTaken Then dtTimeToCheck = dtTimeToCheck + min_Duration_for_slot
' Set the start time to the next available time slot.
Loop
Function:
Public Function CheckAvailability(ByVal argChkDate As Date, _
ByVal argChkTime As Date, ByVal duration As Date) As Boolean
Dim oApp As Object 'Outlook.Application
Dim oNameSpace As Object 'Outlook.NameSpace
Dim oApptItem As Object 'Outlook.AppointmentItem
Dim oFolder As Object 'Outlook.MAPIFolder
Dim oMeetingoApptItem As Object 'Outlook.meetingItem
Dim oObject As Object
Dim ItemstoCheck As Object 'Outlook.Items
Dim strRestriction As String
Dim FilteredItemstoCheck As Object 'Outlook.Items
Dim argCheckDate As Date
Dim daStart As String
Dim daEnd As Variant
'Combine the date and time arguments
argCheckDate = argChkDate + argChkTime
'Avoid past booking of calendar
If argCheckDate < Now Then
CheckAvailability = True
GoTo FUNCEXIT
End If
On Error Resume Next
'Check if Outlook is running
Set oApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
'If not running, start it
Set oApp = CreateObject("Outlook.Application")
End If
'Get the default calendar folder
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.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
daStart = Format(argChkDate, "dd/mm/yyyy hh:mm:ss AMPM")
daEnd = Format(argChkDate + 1, "dd/mm/yyyy hh:mm:ss AMPM")
strRestriction = "[Start] >= '" & daStart & "' AND [End] <= '" & daEnd & "'"
Set FilteredItemstoCheck = ItemstoCheck.Restrict(strRestriction)
'Check if there is a conflicting appointment
CheckAvailability = False
For Each oObject In FilteredItemstoCheck
If oObject.Class = olAppointment Or oObject.Class = olMeetingRequest Then
Set oApptItem = oObject
If (oObject.Start = argCheckDate) _
Or oObject.End = (argCheckDate + duration) _
Or (argCheckDate > oObject.Start And argCheckDate < oObject.End) _
Or ((argCheckDate + duration) > oObject.Start And (argCheckDate + duration) < oObject.End) _
Or oObject.Start > argCheckDate And oObject.Start < (argCheckDate + duration) Then
CheckAvailability = True
Exit For
End If
End If
Next oObject
FUNCEXIT:
'Cleanup
Set oApp = Nothing
Set oNameSpace = Nothing
Set oApptItem = Nothing
Set oFolder = Nothing
Set oObject = Nothing
End Function
In Windows 10
' argCheckDate and hh:mm
daStart = Format(argCheckDate, "dd/mm/yyyy hh:mm AMPM")
daEnd = Format(argCheckDate + 1, "dd/mm/yyyy hh:mm AMPM")
Option Explicit
Sub calenderTest()
'below should in return true if already booked
MsgBox (CheckAvailability("28/11/2024", "11:00", "20"))
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
'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 & "'"
Set FilteredItemstoCheck = ItemstoCheck.Restrict(strRestriction)
'Check if there is a conflicting appointment
CheckAvailability = False
For Each oObject In FilteredItemstoCheck
If oObject.Class = olAppointment Or oObject.Class = olMeetingRequest Then
Set oApptItem = oObject
If (oObject.Start = argCheckDate) _
Or oObject.End = (argCheckDate + duration) _
Or (argCheckDate > oObject.Start And argCheckDate < oObject.End) _
Or ((argCheckDate + duration) > oObject.Start And (argCheckDate + duration) < oObject.End) _
Or oObject.Start > argCheckDate And oObject.Start < (argCheckDate + duration) Then
CheckAvailability = True
Exit For
End If
End If
Next oObject
End Function
If you need to know CreateObject was used from say Excel VBA. If the user did not have Outlook open, you can close Outlook.
Option Explicit
Sub getCreateOutlookfromOtherApplication()
Dim oApp As Object
Dim myFolder As Object
Dim isCreated As Boolean
'Check if Outlook is running
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
' Consider mandatory and as close as possible to On Error Resume Next
On Error GoTo 0
'If not running, start it
If oApp Is Nothing Then
Set oApp = CreateObject("Outlook.Application")
isCreated = True
End If
Set myFolder = oApp.session.GetDefaultFolder(6) ' olFolderInbox
myFolder.Display
' Close / Quit only if isCreated = True
End Sub