[AccessD] Appointment collisions

John W. Colby jwcolby at colbyconsulting.com
Wed Apr 7 21:12:12 CDT 2004


For anyone who has never seen the code, Lembit donated the following code
which I documented and placed into a function which checks for appointment
collisions.  I just finished building a set of two queries and a report to
display any collisions between times entered into my billing programs.  I
work on site a lot and if I don't have my laptop I keep an email open which
I then email home to myself with my hours and a brief summary of what I am
doing.  In any case I end up copying that into my billing program every few
days.  I have always "manually" checked my hours to make sure I didn't enter
times in wrong, but a simple report to tell me if I am entering overlapping
times is a must.  There is nothing more embarrassing that billing the
customer twice for the same time!

The following is the function.

Option Compare Database
Option Explicit
'.=========================================================================
'.Copyright 2001 Colby Consulting.  All rights reserved.
'.Phone        :
'.E-mail       : jcolby at colbyconsulting.com
'.=========================================================================
' DO NOT DELETE THE COMMENTS ABOVE.  All other comments in this module
' may be deleted from production code, but lines above must remain.
'--------------------------------------------------------------------------
'.Written By   : John W. Colby
'.Date Created : 12/31/2001
' Rev. History :
'.Description  :
'
' Comments     :
'.-------------------------------------------------------------------------
'.
' ADDITIONAL NOTES:
'
'FUNCTIONS SPECIFIC TO THIS APPLICATION
'
'.
'*+ Compiler directives
#Const DebugPrint = True        'TURNS ON/OFF ALL NORMAL DEBUG PRINTING
THROUGHOUT THE PROJECT
#Const DebugPrintEvent = True  'TURNS ON/OFF ALL EVENT DEBUG PRINTING
THROUGHOUT THE PROJECT
'*- Compiler directives
'*+ Module constant declaration
Private Const mcstrModuleName As String = "basApp"    'THE NAME OF THIS
MODULE
'*- Module constant declaration
'*+ Module Variable declaration
'*- Module Variable declaration

Public Function TCComputeTime(ST, ET, SD, ED, Billable, Optional
blnComputeBillable As Boolean = True) As Double
On Error GoTo Err_TCComputeTime
Dim Time As Double
    If blnComputeBillable Then
        If Billable = True Then
            Time = DateDiff("n", ST, ET) / 60
            If DateDiff("d", SD, ED) = 1 Then
               Time = Time + 24
            End If
            '   Time = Format(Time, "00.00")
            Time = Format(Time, "00.0000")
            TCComputeTime = Time
        Else
            TCComputeTime = 0
        End If
    Else
        Time = DateDiff("n", ST, ET) / 60
        If DateDiff("d", SD, ED) = 1 Then
           Time = Time + 24
        End If
        '   Time = Format(Time, "00.00")
        Time = Format(Time, "00.0000")
        TCComputeTime = Time
    End If
Exit_TCComputeTime:
Exit Function
Err_TCComputeTime:
    Select Case Err
    Case 0      '.insert Errors you wish to ignore here
        Resume Next
    Case Else   '.All other errors will trap
        Beep
        MsgBox Err.Description, , "Error in Function basApp.TCComputeTime"
        Resume Exit_TCComputeTime
    End Select
    Resume 0    '.FOR TROUBLESHOOTING
End Function

'Comments  :
'Parameters:
'Sets      :
'Returns   :   CURRENT TIME ROUNDED UP OR DOWN TO 10 MINUTE INTERVALS
'Created by: Colby Consulting
'Created   : 9/29/98 11:00:35 AM
Function ccRoundTimeOld(Optional intRoundInterval As Integer = 10)
On Error GoTo Err_ccRoundTime

Dim dtmTime As Date          'HOLDS THE CURRENT TIME FOR MANIPULATION
Dim intMin As Integer        'MINUTE PORTION OF THE TIME VALUE
Dim intTarget As Integer   'TARGET MINUTES TO ROUND TO
Dim intBillRound As Integer   '1/2 THE INTERVAL
Dim intRoundAmt As Integer 'THE AMOUNT TO ROUND UP OR DOWN


   intBillRound = intRoundInterval / 2
   dtmTime = Time()
   intMin = DatePart("n", dtmTime)

   'ADD THE BILL INTERVAL TO ZERO UNTIL IT IS JUST UNDER THE MINUTES
   Do While intTarget + intRoundInterval <= intMin
      intTarget = intTarget + intRoundInterval
   Loop

   'FIGURE OUT IF WE'RE OVER OR UNDER THE HALF WAY POINT OF THE BILL
INTERVAL
   'AND ADD OR SUBTRACT THE CORRECT AMOUNT AS NEEDED
   If intMin - intTarget >= intBillRound Then
      intTarget = intTarget + intRoundInterval
      intRoundAmt = intTarget - intMin
      dtmTime = DateAdd("n", intRoundAmt, dtmTime)
   Else
      intRoundAmt = intTarget - intMin
      dtmTime = DateAdd("n", intRoundAmt, dtmTime)
   End If

   'ROUND OFF THE SECONDS TO ZERO
   dtmTime = DatePart("h", dtmTime) & ":" & DatePart("n", dtmTime) & ":00"

   'PASS BACK THE VALUE
   ccRoundTimeOld = dtmTime

Exit_ccRoundTime:
Exit Function

Err_ccRoundTime:
   Select Case Err
   Case 0      'insert Errors you wish to ignore here
      Resume Next
   Case Else   'All other errors will trap
      Beep
      MsgBox Err.Description, , "Error in function Module1.ccRoundTime"
   Resume Exit_ccRoundTime
   End Select
   Resume 0 'FOR TROUBLESHOOTING
End Function

Function ccRoundTime(ByVal varTime As Variant, Optional ByVal intRound As
Integer = 10) As Variant

' ccRoundTime returns varTime rounded to hours and minutes by intRound.
' intRound is the rounding value in minutes.
'
' Examples:
' ccRoundTime(#15:52:30#,15) returns 15:45:00.
' ccRoundTime(varTime,120) returns varTime rounded to even hours.
' ccRoundTime(varTime,6) returns varTime rounded to tens of an hour.
'
' (c) 1997, Cactus Data ApS, Copenhagen.
' May be freely used or modified.

On Error GoTo Err_ccRoundTime
' Limit intRound to minut count for one day.
intRound = intRound Mod (24 * 60)

If IsDate(varTime) And (intRound > 0) Then
    ' Round seconds to minutes.
    varTime = TimeSerial(Hour(varTime), Minute(varTime),
CInt(Second(varTime) / 60) * 60)
    ' Return varTime rounded by intRound using hours calculated as minutes.
    ccRoundTime = TimeSerial(0, CInt((Hour(varTime) * 60 + Minute(varTime))
/ intRound) * intRound, 0)
Else
    ' Return varTime as is.
    ccRoundTime = varTime
End If

Exit_ccRoundTime:
    Exit Function

Err_ccRoundTime:
    ccRoundTime = 0
    Resume Exit_ccRoundTime

End Function

Function C2DbPopulateInvLI(frm As Form, strSQL As String)
On Error GoTo Err_C2DbPopulateInvLI
    MsgBox "strsql"
Exit_C2DbPopulateInvLI:
Exit Function
Err_C2DbPopulateInvLI:
    Select Case Err
    Case 0      '.insert Errors you wish to ignore here
        Resume Next
    Case Else   '.All other errors will trap
        Beep
        MsgBox Err.Description, , "Error in Function
basApp.C2DbPopulateInvLI"
        Resume Exit_C2DbPopulateInvLI
    End Select
    Resume 0    '.FOR TROUBLESHOOTING
End Function

'Comments  :    THANKS TO LEMBIT SOOBIK
'there is a 'simple' equation which defines a conflict in appointments:
'let's name the starting point of an existing appointment Se, endpoint Ee
'and for the new appointment to be tested the starting point St, endpoint Et
'now you can simply check
'
'If St < Ee AND Et > Se
'
'then you have a conflict.
'you can easily visualize that by following drawing
'
'_________Se______Ee______
'1_St__Et
'2_St_________Et
'3_St__________________Et
'4___________St_Et
'5___________St________Et
'6_____________________St__Et
'
'As you can see, only cases 2, 3, 4, 5 have a conflict. case 1 does not have
a conflict because it ends before the existing one starts (Et < Se) and 6
does not have a conflict since it starts after the existing ends (St > Ee.
'
'Parameters:
'Sets      :
'Returns   :
'Created by: Colby Consulting
'Created   : 6/25/99 11:43:56 AM
Function ccApptCollision(IDNew As Long, dtmSTNew As Date, dtmETNew As Date,
_
                        IDExist As Long, dtmSTExist As Date, dtmETExist As
Date) As Boolean
On Error GoTo Err_ccApptCollision
#If boolELE Then
    Call gProcStack.EnterProc("ccApptCollision", "Module1")
#End If

    'CHECK IF WE ARE COMPARING A RECORD TO ITSELF
    If IDNew = IDExist Then
        ccApptCollision = False
        Exit Function
    End If

    'CHECK FOR COLLISIONS
    If (dtmSTNew < dtmETExist) And (dtmETNew > dtmSTExist) Then
        ccApptCollision = True
    Else
        ccApptCollision = False
    End If

Exit_ccApptCollision:
#If boolELE Then
    Call gProcStack.ExitProc("ccApptCollision")
#End If
Exit Function

Err_ccApptCollision:
#If boolELE Then
    WriteErrorLog Err
#End If
    Select Case Err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox Err.Description, , "Error in function
Module1.ccApptCollision"
    Resume Exit_ccApptCollision
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function

**********

In my billing I keep the time and date separate.  I then build a query where
I drop the time table in twice, join on the date, then add the time and date
fields into a single value and pass them into the parameters of the function
above as well as the time record IDs from the two records.  Out pops a true
/ false value that tells me if I have a collision.  You can actually do the
same without any join but the result set can get huge in a hurry so you will
need to limit the date ranges.

Again, thanks to Lembit for the logic.

John W. Colby
www.ColbyConsulting.com





More information about the AccessD mailing list