I am currently building an Lease Database with access and need to keep track of the renewal and ending dates of multiple leases at once. For that purpose, I am trying to maintain a calendar inside the database that would track the information.
It shows month and year through a combo box and every day of the month through text boxes. Within each text box, the goal is to have a clickable entry that leads to a form that states which event is due that day such as "Lease Renewal" or "End of Lease". The entries will load through an array.
I was lucky enough to find the code for such a calendar through a youtuber named "Access All in One" who gave us a license to use and modify his code. FOr some reason, the array that I modified is not functional and I do not know why.
This was the calendar array original code
Code:
Public Sub LoadArray()'This sub loads an array with the relevant variables from a query
Dim db As Database
Dim rs As Recordset
Dim rsFiltered As Recordset
Dim strQuery As String
Dim i As Integer
On Error GoTo ErrorHandler
strQuery = "SELECT tblClass.ClassID, tblClass.ClassDate, tblLocations.ClassRoom, "
strQuery = strQuery & "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[StartTime]) AS StartTime, "
strQuery = strQuery & "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[EndTime]) AS EndTime, "
strQuery = strQuery & "tblLevel.Level, tblLevel.Code, Left([tblTeachers].[FirstName],1) & Left([tblteachers].[LastName],1) AS Teacher "
strQuery = strQuery & "FROM tblLocations INNER JOIN ((tblCourse INNER JOIN tblLevel ON tblCourse.Level = tblLevel.LevelID) "
strQuery = strQuery & "INNER JOIN (tblClass INNER JOIN tblTeachers ON tblClass.TeacherID = tblTeachers.TeacherID) "
strQuery = strQuery & "ON tblCourse.CourseID = tblClass.CourseID) ON tblLocations.LocationID = tblClass.LocationID "
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)
With rs
If Not rs.BOF And Not rs.EOF Then
'Ensures the recordset contains records
For i = 0 To UBound(MyArray)
'Will loop through the array and use dates to filter down the query
'It firsts checks that the second column has true for its visible property
If MyArray(i, 1) = True Then
.Filter = "[ClassDate]=" & MyArray(i, 0)
'To filter you must open a secondary recordset and
'Use that as the basis for a query
'This makes sense as you are building a query on a query
Set rsFiltered = .OpenRecordset
If Not rsFiltered.BOF And Not rsFiltered.EOF Then
'If the recordset is not empty then you are able
'to extract the text from the values provided
Do While Not rsFiltered.EOF = True
MyArray(i, 2) = MyArray(i, 2) & vbNewLine & rsFiltered!starttime
MyArray(i, 2) = MyArray(i, 2) & " - " & rsFiltered!endtime
MyArray(i, 2) = MyArray(i, 2) & " " & rsFiltered!code
rsFiltered.MoveNext
Loop
End If
End If
Next i
End If
.Close
End With
ExitSub:
Set db = Nothing
Set rs = Nothing
Exit Sub
ErrorHandler:
MsgBox "There has been an error. Please reload the form.", , "Error"
Resume ExitSub
End Sub
Public Sub PrintArray()
Dim strTextBox As String
Dim i As Integer
On Error GoTo ErrorHandler
For i = 0 To 41
strTextBox = "txt" & CStr(i + 1)
With Me
Controls(strTextBox) = ""
Controls(strTextBox).tag = i + 1
Controls(strTextBox) = MyArray(i, 2)
'Debug.Print strTextBox
'MyArray(i, 2)
End With
Next i
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "There has been an error. Please reload the form.", , "Error"
Resume ExitSub
End Sub
This is my array:
Code:
Public Sub LoadArray()
'This sub loads an array with the relevant variables from a query
Dim db As Database
Dim rs As Recordset
Dim rsFiltered As Recordset
Dim strQuery As String
Dim i As Integer
On Error GoTo ErrorHandler
strQuery = "SELECT CalendarDatestbl.LeaseID, CalendarDatestbl.EventDate, CalendarDatestbl.Unit, CalendarDatestbl.Usage,"
strQuery = strQuery & "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [CalendarDatestbl].[StartTime]) AS StartTime, "
strQuery = strQuery & "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [CalendarDatestbl].[EndTime]) AS EndTime, "
strQuery = strQuery & "Eventtbl.Event AS Event, Eventtbl.Code AS Code"
strQuery = strQuery & "FROM CalendarDatestbl INNER JOIN Eventtbl ON CalendarDatestbl.Event = Eventtbl.Event"
strQuery = strQuery & "ORDER BY CalendarDatestbl.EventDate, DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [CalendarDatestbl].[StartTime]);"
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)
With rs
If Not rs.BOF And Not rs.EOF Then
'Ensures the recordset contains records
For i = 0 To UBound(MyArray)
'Will loop through the array and use dates to filter down the query
'It firsts checks that the second column has true for its visible property
If MyArray(i, 1) = True Then
.Filter = "[EventDate]=" & MyArray(i, 0)
'To filter you must open a secondary recordset and
'Use that as the basis for a query
'This makes sense as you are building a query on a query
Set rsFiltered = .OpenRecordset
If Not rsFiltered.BOF And Not rsFiltered.EOF Then
'If the recordset is not empty then you are able
'to extract the text from the values provided
Do While Not rsFiltered.EOF = True
MyArray(i, 2) = MyArray(i, 2) & vbNewLine & rsFiltered!StartTime
MyArray(i, 2) = MyArray(i, 2) & " - " & rsFiltered!EndTime
MyArray(i, 2) = MyArray(i, 2) & " " & rsFiltered!code
MyArray(i, 2) = MyArray(i, 2) & " " & rsFiltered!leaseid
rsFiltered.MoveNext
Loop
End If
End If
Next i
End If
.Close
End With
ExitSub:
Set db = Nothing
Set rs = Nothing
Exit Sub
ErrorHandler:
MsgBox "There has been an error. Please reload the form.", , "Error"
Resume ExitSub
End Sub
Public Sub PrintArray()
Dim strTextBox As String
Dim i As Integer
On Error GoTo ErrorHandler
For i = 0 To 41
strTextBox = "txt" & CStr(i + 1)
With Me
Controls(strTextBox) = ""
Controls(strTextBox).tag = i + 1
Controls(strTextBox) = MyArray(i, 2)
'Debug.Print strTextBox
'MyArray(i, 2)
End With
Next i
ExitSub:
Exit Sub
ErrorHandler:
MsgBox "There has been an error. Please reload the form.", , "Error"
Resume ExitSub
End Sub