下面的代码在我的笔记本电脑上运行良好，但在 Windows 10 机器上使用相同的代码时不起作用。注入新预约有效，但它确实会在同一时间再次预订两次，而不是在 Windows 11 Business 中。
要在 Outlook 中测试它，请像这样调用（输入您预约的日期/时间）
Function calenderTest()
'below should in return true if already booked
msgbox(CheckAvailability("28/11/2024", "11:00", "20"))
End Function
调用下面函数的部分
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
功能：
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
在 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
如果您需要知道
CreateObjectOption 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