I apologize in advance for this lengthy question and just want to put it out there that I am very new to VBA programming and am open to suggestions to change code to allow the database to run more quickly and smoothly without losing the current functionality.
What I've created is a form used to schedule patients. The form contains a subform that displays records based on what is selected in a text box and two combo boxes. First, the user chooses a doctor listed in the first combobox (DoctorsName), selects a date (txtAppointDate). Then, the Available Times combobox (cboTime) populates and displays times available based on DoctorsName and txtAppointDate selections.
So what I'm trying to do is have a button or checkbox control that when selected, it automatically populates the next date with an open time slot and displays in the txtAppointDate field. I am fine with any other options besides a button or checkbox but am just looking for a way for users to simply look for the next available date/time. I am familiar with the FindFirst and NoMatch properties but am not quite sure how they would work in this instance.
Below is my code. Thanks so much for the help!
Private Sub cboTime_Enter()
Dim i As Date, n As Integer, oRS As DAO.Recordset, sSQL As String
Dim dDuration As Date, dEnd As Date, dStart As Date
Dim dLowerPrecision As Date, dUpperPrecision As Date
cboTime.RowSourceType = "Value List"
cboTime.RowSource = ""
If IsNull(Start) Then Exit Sub Else i = Start
If Me.NewRecord = True Then
DoCmd.RunCommand acCmdSaveRecord
End If
sSQL = "SELECT DoctorsID, AppointDate, AppointTime"
sSQL = sSQL & " FROM qrySubformAppoints"
sSQL = sSQL & " WHERE DoctorsID= " & Me.ID & _
" AND AppointDate=#" & Me.txtAppointDate & "#"
Set oRS = CurrentDb.OpenRecordset(sSQL)
dDuration = TimeValue("00:30")
If Weekday(Me.txtAppointDate, vbSaturday) = 3 Then
dEnd = EndMon - TimeValue("00:25")
dStart = StartMon - TimeValue("00:25")
ElseIf Weekday(Me.txtAppointDate, vbSaturday) = 4 Then
dEnd = EndTues - TimeValue("00:25")
dStart = StartTues - TimeValue("00:25")
ElseIf Weekday(Me.txtAppointDate, vbSaturday) = 5 Then
dEnd = EndWed - TimeValue("00:25")
dStart = StartWed - TimeValue("00:25")
ElseIf Weekday(Me.txtAppointDate, vbSaturday) = 6 Then
dEnd = EndThurs - TimeValue("00:25")
dStart = StartThurs - TimeValue("00:25")
Else
dEnd = EndFri - TimeValue("00:25")
dStart = StartFri - TimeValue("00:25")
End If
If oRS.RecordCount = 0 Then
Do
If i >= dStart And i <= dEnd Then
cboTime.AddItem i
End If
i = i + dDuration
Loop Until i >= dEnd
Else
Do
If i >= dStart And i <= dEnd Then
dLowerPrecision = i - TimeValue("00:00:05")
dUpperPrecision = i + TimeValue("00:00:05")
oRS.FindFirst "[AppointTime] Between #" & dLowerPrecision & "# And #" & dUpperPrecision & "#"
If oRS.NoMatch Then cboTime.AddItem i
End If
i = i + dDuration
Loop Until i >= dEnd
End If
oRS.Close
End Sub
Private Sub cboTime_AfterUpdate()
subform.SetFocus
DoCmd.GoToControl "AppointTime"
DoCmd.GoToRecord , , acNewRec
subform.Form.Controls("AppointTime") = Me.cboTime
subform.Form.Controls("AppointDate") = Me.txtAppointDate
subform.Form.Controls("cboClient").SetFocus
subform.Form.Controls("cboClient").Dropdown
End Sub
Private Sub txtAppointDate_BeforeUpdate(Cancel As Integer)
If Weekday(Me.txtAppointDate, vbSaturday) <= 2 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 1 And Weekday(Me.txtAppointDate, vbSaturday) = 3 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 1 And Weekday(Me.txtAppointDate, vbSaturday) = 4 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 1 And Weekday(Me.txtAppointDate, vbSaturday) = 6 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 2 And Weekday(Me.txtAppointDate, vbSaturday) = 3 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 2 And Weekday(Me.txtAppointDate, vbSaturday) = 4 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 2 And Weekday(Me.txtAppointDate, vbSaturday) = 6 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 4 And Weekday(Me.txtAppointDate, vbSaturday) = 3 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 4 And Weekday(Me.txtAppointDate, vbSaturday) = 4 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 4 And Weekday(Me.txtAppointDate, vbSaturday) = 6 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 6 And Weekday(Me.txtAppointDate, vbSaturday) = 3 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 6 And Weekday(Me.txtAppointDate, vbSaturday) = 4 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
If Me.ID = 6 And Weekday(Me.txtAppointDate, vbSaturday) = 6 Then
Cancel = True
MsgBox ("No appointments available on this date")
End If
End Sub
Aucun commentaire:
Enregistrer un commentaire