Function FrstDay(D As Variant, ReqWeekday As Integer) As Date
' Returns the date of the first specified day in a month
' FirstWeekDay 1 - Sunday, 2 - Monday, 3 - Tuesday, etc.
FrstDay = NextDay(EndOfMonthPrev(D), ReqWeekday)
End Function
Function NextDay(D As Variant, DayCode As Integer) As Variant
' Returns the date of the next DayCode (1=Sun ... 7=Sat) after the
' date D.
NextDay = D - WeekDay(D) + DayCode + IIf(WeekDay(D) < DayCode, 0, 7)
End Function
Function EndOfMonthPrev(D As Variant) As Variant
' Returns the date representing the last day of the previous month.
' Arguments:
' D = Date
EndOfMonthPrev = DateSerial(Year(D), Month(D), 0)
End Function
Public Function RunOffencesRep(D As Variant, intMonths As Integer)
' Accepts a date equivalent to latest date of report and finds pupils
' with 3 or more offences in any consecutive 2 week period in the previous
' intMonths months, a pupil may appear more than once but for different
' consecutive fortnights
' D = Date, this date is not included in the report
' intMonths = no of months the report is to run back for
Dim dteMax As Date, dteMin As Date, dteMonday As Date, dteFriday As Date
Dim strSQL As String
Dim db As DAO.Database
dteMax = D
dteMin = dteMax - (intMonths * 30)
dteMonday = FrstDay(dteMin, 2)
' find first Monday equivalent to intMonths months ago
Do While dteMonday < dteMin
dteMonday = dteMonday + 7
Loop
' find Friday of 2 weeks later
dteFriday = dteMonday + 11
' need to clear out records from report table
strSQL = "DELETE * from Off3M"
' do delete using strSQL
Set db = CurrentDb
db.Execute strSQL
rst.Close
db.Close
' continue for each week until end date reached
Do While dteFriday < (dteMax - 1)
' Find pupils who have 3 or more offences for two weeks between
' dteMonday and dteFriday
FindPupils dteMonday, dteFriday
' move on one week to Monday & Friday of next fortnight
dteMonday = dteMonday + 7
dteFriday = dteFriday + 7
Loop
' open report showing details of pupils with 3 or more offences
'DoCmd.OpenReport "3orMore", acViewPreview
End Function
Public Function FindPupils(dteMon As Date, dteFri As Date)
' find pupils with 3 or more offences between the dates received
' and append a record to a table
Dim strSQL As String
Dim db As DAO.Database
Dim rstOff As DAO.Recordset
' assuming table called Offences with PupilID, OffenceDate and OffenceID then use SQL to get pupils
' with 3 or more offences
strSQL = "SELECT Offences.PupilID, Count(Offences.OffenceID) AS Offences FROM Offences WHERE "
strSQL = strSQL & "(((Offences.OffenceDate) Between #" & Format(dteMon, "mm/dd/yyyy") & "# And #" & Format(dteFri, "mm/dd/yyyy") & "#)) "
strSQL = strSQL & "GROUP BY Offences.PupilID HAVING (((Count(Offences.OffenceID))>=3));"
Set db = CurrentDb
' open a recordset with strSql
Set rstOff = db.OpenRecordset(strSQL)
' loop through the recordset and append to a table containing pupils with 3 or more offences
' append PupilID, No of Offences, dteMon and dteFri
Do While Not rstOff.EOF
strSQL = "INSERT INTO Off3M ( PupilID, Offences, StartDate, EndDate ) "
strSQL = strSQL & "VALUES (" & rstOff.PupilID & ", " & rstOff.Offences & ", #" & dteMon & "# , #" & dteFri & "#);"
' do append using strSql
db.Execute strSQL
rstOff.MoveNext
Loop
rstOff.Close
db.Close
End Function
