Question

我提前为这个冗长的问题道歉并且只是想把它放在那里我对VBA编程很陌生并且愿意改变代码以允许数据库更快更顺畅地运行而不会丢失当前的功能

我创建的是用于安排患者的表格。该表单包含一个子窗体，该子窗体根据文本框和两个组合框中选择的内容显示记录。首先，用户选择第一个组合框（DoctorsName）中列出的医生，选择日期（txtAppointDate）。然后，可用时间组合框（cboTime）根据DoctorsName和txtAppointDate选项填充并显示可用时间。

所以我要做的是有一个按钮或复选框控件，当选中它时，它会自动使用打开的时间段填充下一个日期并显示在txtAppointDate字段中。除了按钮或复选框之外，我可以使用任何其他选项，但我只是在寻找一种方法让用户只需查找下一个可用的日期/时间。我熟悉FindFirst和NoMatch属性，但我不太确定它们在这个实例中的工作方式。

以下是我的代码。非常感谢你的帮助！

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

Answer 1

您可以使用更清晰的选择案例简化相当多的长嵌套If / Elseif部分。至于移动到所需的记录集，请尝试使用recordsetclone，如果找到则匹配原始记录集中的书签位置。

    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
    Dim rs As Object
    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")

    Select Case Weekday(Me.txtAppointDate, vbSaturday)
        Case 3,4,5,6
            dEnd = End - TimeValue("00:25")
            dStart = Start - TimeValue("00:25")
        Case else
            dEnd = End - TimeValue("00:25")
            dStart = Start - TimeValue("00:25")
    End Select

    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")
                Set rs = Me.RecordsetClone    
                rs.FindFirst "[AppointTime] Between #" & dLowerPrecision & "# And #" & dUpperPrecision & "#"
                If Not rs.EOF Then 
                    Me.Bookmark = rs.Bookmark
                Then
                    cboTime.AddItem i
                End if
            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)

    Select Case Weekday(Me.txtAppointDate, vbSaturday)
        Case IS <=2, 3,4,6          
            Cancel = True
            MsgBox ("No appointments available on this date")
        Case else
            'nothing?
    End Select  

End Sub

FindFirst NoMatch基于Access 2007表中的2列

1 个答案: