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