Option Compare Database
Private date1 As Date, date2 As Date
Private selDate As Date
Private boolRedraw As Boolean
Private db1 As New ADODB.Connection
Private Sub Command10_Click()
Me.Requery
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
Me.Requery
UpdateDay fldDate
End Sub
Private Sub Form_AfterUpdate()
UpdateDay fldDate
End Sub
Private Sub Form_Load()
Me.MonthView0.Value = Now
MonthView0_DateClick (Now)
Me.FilterOn = True
Me.TimerInterval = 1
End Sub
Private Sub Form_Timer()
'date1 = Empty
'date2 = Empty
Me.fldDate.SetFocus
UpdateDayBold
'boolRedraw = False
Me.TimerInterval = 0
End Sub
Private Sub lstEvents_Click()
On Error GoTo Err_PopulateEventsList
Dim strSQL2 As String
strSQL2 = "SELECT Qry_CalData.DateA,Qry_CalData.LastName,Qry_CalData.TimeFrom,Qry_CalData.TimeTo,Qry_CalData.ID "
strSQL2 = strSQL2 & "FROM Qry_CalData "
strSQL2 = strSQL2 & "WHERE (((Qry_CalData.DateA)=" & ctlDayBlock.Tag & "));"
lstEvents.RowSource = strSQL2
lblEventsOnDate.Caption = Format(ctlDayBlock.Tag, "mm-dd-yyyy")
lstEvents.visible = True
lblEventsOnDate.visible = True
Exit_PopulateEventsList:
Exit Sub
Err_PopulateEventsList:
MsgBox Err.Description, vbExclamation, "Error in PopulateEventsList()"
Resume Exit_PopulateEventsList
End Sub
Public Sub MonthView0_DateClick(ByVal DateClicked As Date)
Me.fldDate.SetFocus
Me.Filter = "fldDate=#" & Format(DateClicked, "short date") & "#"
Me.Requery
selDate = Format(Me.MonthView0.Value, "short date")
Debug.Print ("date click " & boolRedraw)
End Sub
Public Sub MonthView0_SelChange(ByVal StartDate As Date, ByVal EndDate As Date, Cancel As Boolean)
'UpdateDayBold
Me.fldDate.SetFocus
If selDate <> Format(Me.MonthView0.Value, "short date") Then
MonthView0_DateClick Format(Me.MonthView0.Value, "short date")
End If
Me.TimerInterval = 1
End Sub
Private Sub UpdateDayBold()
If Not boolRedraw Then
boolRedraw = True
Dim dt1 As Date, dt2 As Date
dt1 = Format(Me.MonthView0.VisibleDays(1))
Dim x1 As Integer
x1 = 110
On Error Resume Next
dt2 = Format(Me.MonthView0.VisibleDays(x1), "short date")
While Err.Number <> 0
Err.Clear
x1 = x1 - 1
dt2 = Format(Me.MonthView0.VisibleDays(x1), "short date")
DoEvents
Wend
On Error GoTo 0
If date1 = dt1 And date2 = dt2 Then
boolRedraw = False
Exit Sub
End If
date1 = dt1
date2 = dt2
'Me.MonthView0.Visible = False
'Dim db1 As New ADODB.Connection
Set db1 = CurrentProject.Connection
For dt = dt1 To dt2
UpdateDay CDate(dt)
Next
'Err.Clear
'Me.Requery
'Me.MonthView0.Visible = True
boolRedraw = False
'MonthView0.Locked = False
End If
End Sub
Private Sub UpdateDay(dt As Date)
Dim view1 As New ADODB.Recordset
view1.Open "select fldDate from [Table1] where fldDate=#" & Format(dt, "short date") & "#", db1, adOpenKeyset, adLockBatchOptimistic, ADODB.adCmdText
On Error Resume Next
Me.MonthView0.DayBold(dt) = Not view1.EOF
Debug.Print Format(dt, "Short Date") & " : " & Err.Description
Err.Clear
On Error GoTo 0
view1.Close
Set view1 = Nothing
DoEvents
End Sub
Private Sub PopulateEventsList(ctlDayBlock As control)
On Error GoTo Err_PopulateEventsList
Dim strSQL2 As String
strSQL2 = "Table1.FldDate, Table1.Employee, Table1.TimeFrom, Table1.TimeTo, Table1.NewID "
strSQL2 = strSQL2 & "FROM Table1 "
strSQL2 = strSQL2 & "WHERE (((Table1.FldDate)=" & ctlDayBlock.Tag & "));"
lstEvents.RowSource = strSQL2
lblEventsOnDate.Caption = Format(ctlDayBlock.Tag, "mm-dd-yyyy")
lstEvents.visible = True
lblEventsOnDate.visible = True
Exit_PopulateEventsList:
Exit Sub
Err_PopulateEventsList:
MsgBox Err.Description, vbExclamation, "Error in PopulateEventsList()"
Resume Exit_PopulateEventsList
End Sub
Private Sub Command44_Click()
On Error GoTo Err_Command44_Click
DoCmd.RunCommand acCmdSelectRecord
DoCmd.RunCommand acCmdDeleteRecord
Exit_Command44_Click:
Exit Sub
Err_Command44_Click:
MsgBox Err.Description
Resume Exit_Command44_Click
End Sub
