自动日历预约未正确预订。尊重开始时间但不考虑结束时间

Question

如果您在 30 点至 11 点 11 点至 12 点有预约，它将仅查看 11 点并添加 20 个默认时间，并在 11 点 20 分至 11 点 40 分插入预约，而不是 12 点至 12 点 20 分。

已尝试更改

duration as long

甚至

duration = DateAdd("n", duration, argChkTime)

以及Nitton的建议，但遗憾的是未能找到解决方案。

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", "[email protected]", "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
  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 dtTimeToCheck = dtTimeToCheck + min_Duration_for_slot ' Set the start time to the next available time slot.
  Loop
  If SlotIsTaken Then
  Debug.Print ("....Busy")
  Else
  Debug.Print ("Creating an appointement")
  End If

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.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 oMeetingoApptItem = Nothing
    Set oFolder = Nothing
    Set oApptItem = Nothing
    Set oObject = Nothing
End Function

Answer 1

我将

argChkDate

返回到过滤器。

持续时间变量声明为

Long

而不是

Date

。

我将

If

语句分成多个部分来看看它做了什么。您可以将

DateAdd

应用于原始单曲

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", "[email protected]", "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