Appointment Collision Check

You’ve created a database for scheduling appointments, one little problem when entering these appointments you can’t tell if it clashes with another appointment (especially, if you are not the only one entering).  You could use a query but I always thought this would be handled better in a Module besides, I had an old database from 2002 (sorry, site no longer up so I can’t post a link) that was already part of the way there.  So, this looked like a good time to *make it work*!  Let’s get started…

My parameters:

(In this example I am using the below table, you will need to change the names here and in the Module to match yours.)

tblActivities
aActivityID (PK, Autonumber)
aAssociateID (FK related to tblAssociateProfile, Number, Long Integer)
aDate (Date/Time, Short Date [ No need to use Input Mask at Table Level ])
aStartTime (Date/Time, Medium Time [ Input Mask: 99:00\ >LL;0;_ ])
aEndTime (Date/Time, Medium Time [ Input Mask: 99:00\ >LL;0;_ ])
etc…

Module (Named: modCollisionCheck)…

You can incorporate into an already existing Module but for ease you can copy/paste the below into a new Module.

Option Compare Database
Option Explicit

Public pubActivityID As Long

Public Function getActivityID()
    getActivityID = pubActivityID
End Function


Function fCollisionCheck(dteDate As Date, stStartTime As Date, etEndTime As Date, lngAssociateID As Long)
'7.11.2016 rtw modified
'https://www.access-diva.com/blog/p=397
    
    Dim dbDuration As Double
    Dim se As Date 'Starting time of appointments already made (in table)
    Dim ee As Date 'Ending time of appointments already made (in table)
    Dim blCollision As Boolean
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim frm As Form
    
    Set frm = Screen.ActiveForm
    Set db = CurrentDb
    Set rs = db.OpenRecordset("tblActivities", dbOpenDynaset)
    
    blCollision = False
    frm.lblCollisionCheck.Caption = " "
    dbDuration = etEndTime - stStartTime
    
        With rs
          Do Until rs.EOF
          'First check if the appointment date on the form is the same as the record in the table.
          'The recordset could be filtered at this point thus avoiding
          'to have to loop through all the records in the Appointment table.
          If !aDate = dteDate And !aAssociateID = lngAssociateID Then
              se = !aStartTime
              ee = !aStartTime + dbDuration
            'Lembit Soobik's nifty formula for checking collisions
            If stStartTime < ee And etEndTime > se And pubActivityID <> !aActivityID Then
                blCollision = True
                frm.lblCollisionCheck.Caption = "Collision"
                'MsgBox "Collision with Appointment ID: " & !aActivityID & vbCrLf _
                & "Starting at: " & se & vbCrLf _
                & "Ending at:  " & ee, vbExclamation, "Collision Check"
            End If
          End If
            .MoveNext
          Loop
            rs.Close
            Set rs = Nothing
        End With
    
    db.Close
    Set db = Nothing
        
        If Not blCollision Then
          frm.lblCollisionCheck.Caption = " "
          'MsgBox "No collisions encountered", vbInformation, "You made it"
        End If

End Function

Form…

Place Label, lblCollisionCheck, on your Form, in this example it’s above the Command Buttons.  You will need to place one on your Form use that potion of the code.  However, if you like you can comment out those lines and use the lines below that are pop-up messages.  (I personally like the Label as no extra clicking required by the End User.)

To use the Module above the Form must be set to Pop-Up = No. If you want the Form to be a Pop-Up in the Module above you must change this…

Set frm = Screen.ActiveForm

to

Set frm = Forms![YOUR FORM NAME]

Side Note: If you want to use a Main Form\Subform set up then the lblCollisionCheck must be on the Main Form, all other Controls can be on the Subform.  Since we are reading the Recordsource of the Subform no need to *worry about* the other Controls.

In the After_Update event of txtStartTime place (note the name of the Controls):

    If Not IsNull(Me.txtEndTime) Then
            Call fCollisionCheck(Me.txtDate, Me.txtStartTime, Me.txtEndTime, Me.cboAssociateID)
    End If

In the After_Update event of txtEndTime place (note the name of the Controls):

    pubActivityID = Me.txtActivityID
    
    Call fCollisionCheck(Me.txtDate, Me.txtStartTime, Me.txtEndTime, Me.cboAssociateID)

In the Lost_Focus event of both the txtStartTime and txtEndTime place (I like the extra Save.):

DoCmd.RunCommand acCmdSaveRecord

In the Forms On_Close event (We want to remember to drop the Public Variable when closing the Form in case we want to use it elsewhere.):

pubActivityID = Empty

So, if you enter an appointment that conflicts with another one (See the message?)…

Now, just change the time and message, Collision, will go away provided there still isn’t one!

 1,534 total views,  1 views today