自动日历预约功能异常：未正确识别结束时间致预约错位

自动日历预约功能无法正确创建预约：仅识别已有预约的开始时间，忽略结束时间。例如，若已有11月30日11:00-12:00的预约，系统仅以11:00为基准，添加默认20分钟时长，生成11:20-11:40的新预约，而非预期的12:00-12:20。

调试打印信息 #

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

已尝试的解决方案 #

• 将duration改为long类型
• 使用duration = DateAdd("n", duration, argChkTime)
• 参考Nitton的相关建议

以上方案均未解决问题。

相关VBA代码 #

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 As Long
  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 Long

  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

内容的提问来源于stack exchange，提问作者Grmn