Dreamweaver
Well-known member
- Local time
- Today, 01:37
- Joined
- Nov 28, 2005
- Messages
- 2,466
Calendar wont display beween 2nd & 12th accdb
I have been trying to solve this for weeks and finally given up so going to post it.
Ever since I upgraded from mdb to accdb front/back end I have been having the problem where the data is not found for dates between 2nd and 12th of any month all other dates display correctly can somebody take a look at the code and see if they can find what I have done if it's me.
I have attached 2 images the first with the purle boxes is the one I'm having the problem with and the one with green boxes if an older version that works just fine with mdb datafiles with over 18 million records across 15 db's
I can't post the whole db but if need be I can pull the form and it's required items out
I have been trying to solve this for weeks and finally given up so going to post it.
Ever since I upgraded from mdb to accdb front/back end I have been having the problem where the data is not found for dates between 2nd and 12th of any month all other dates display correctly can somebody take a look at the code and see if they can find what I have done if it's me.
I have attached 2 images the first with the purle boxes is the one I'm having the problem with and the one with green boxes if an older version that works just fine with mdb datafiles with over 18 million records across 15 db's
I can't post the whole db but if need be I can pull the form and it's required items out
Code:
Public Sub PutInData(E)
Dim sql As String
Dim F As Form
Dim Db As DAO.Database
Dim rs As DAO.Recordset
Dim I As Integer
Dim myDate As Date
Dim Str As String
Dim Sched As DAO.Recordset
Dim StrSch As String
Dim StrMain As String
Dim Mn As DAO.Recordset
Dim RMD As DAO.Recordset
Dim StrRmd As String
Dim StrD As String
Dim D As DAO.Recordset
Dim S As Variant
Dim StrR As Variant
Dim pref As DAO.Recordset
Dim Ev As DAO.Recordset
Dim StEv As String
On Error GoTo HandleErr
'Get the defaults
Set pref = CurrentDb.OpenRecordset("SELECT * FROM StblPreferences", dbOpenSnapshot)
Set F = Forms!frmScheduleCalendar
'Empty out the previous month
For I = 1 To 37
F("text" & I) = Null
F("text" & I).BackColor = pref("EmptyCalendarColour")
F("Day" & I).BackColor = pref("CalenderDateTitle")
Next I
'Construct the record sources for the curret month
sql = "SELECT * FROM [QryCalenderSlots] WHERE ((MONTH(SlotDate) = " & F!Cmonth & " AND YEAR(SlotDate)= " & F!Cyear & " AND [Employee]='" & E & "'" & ")) ORDER BY SlotDate;"
StrRmd = "SELECT * FROM [QryRemindersCalendarDisplay] WHERE ((MONTH(RemindDate) = " & F!Cmonth & " AND YEAR(RemindDate)= " & F!Cyear & " AND [EmployeeTo]='" & E & "'" & ")) ORDER BY RemindDate;"
StEv = "SELECT * FROM [QryCalendarEvents] WHERE ((MONTH(EventDate) = " & F!Cmonth & " AND YEAR(EventDate)= " & F!Cyear & ")) ORDER BY EventDate;"
Set Db = CurrentDb()
Set rs = Db.OpenRecordset(sql, dbOpenSnapshot)
Set RMD = Db.OpenRecordset(StrRmd, dbOpenSnapshot)
Set Ev = Db.OpenRecordset(StEv, dbOpenSnapshot)
'Populate the calendar
For I = 1 To 37
If IsDate(F("date" & I)) Then
myDate = Format(F("date" & I), StrDateFormatExtra)
If myDate = Format(Date, StrDateFormatExtra) Then F("Day" & I).BackColor = pref("CurrentDateColour")
rs.FindFirst "SlotDate = #" & myDate & "#"
If Not rs.NoMatch Then
F("text" & I) = "Entries: " & rs!CSlots & vbCrLf
F("text" & I).BackColor = pref("FullCalendarColour")
End If
RMD.FindFirst "RemindDate = #" & myDate & "#"
If Not RMD.NoMatch Then
F("Rmd" & I).Visible = True
F("text" & I) = F("text" & I) & "Reminder(s): " & RMD!CRemind & vbCrLf
F("text" & I).BackColor = pref("FullCalendarColour") '12058551
End If
Ev.FindFirst "EventDate = #" & myDate & "#"
If Not Ev.NoMatch Then
F("text" & I) = F("text" & I) & Ev!EventName & vbCrLf
F("text" & I).BackColor = pref("HolidayColour")
End If
End If
Next I
rs.Close
RMD.Close
Ev.Close
pref.Close
Db.Close
HandleExit:
Exit Sub
HandleErr:
Select Case Err.Number
Case 2501 'Cancel = True
Exit Sub
Case Else
Call GlobalErrs(Err.Number, Err.Description, Err.Source, "ModCalendar", "Sub: PutInData")
Resume HandleExit
Resume
End Select
End SubAttachments
-
2019-01-03.png -
2019-01-03 (1).png
Last edited:
