Here is the entire module:
Private Sub cmdSOQ_Click()
DoCmd.Hourglass True
Dim dbs As Database
Dim rst As Recordset
Dim rstSrc, rstDest As Recordset
Dim strMsgBar As String
Dim lngCount As Long
Dim varReturn As Variant
Dim rstDate As Recordset
Dim wspTrans As Workspace
Dim fldSrc As Field
Dim StartT As Date
Dim startE As Date
Dim rstStuUp, rstTemp As Recordset
Dim sqlHist As String
Dim strInput As String
Dim strMsg As String
Dim txtInc As Long
Dim lngValue As Long
txtInc = 1
Call GetUser(gstrCurrentUser)
strMsg = "Enter new quarter start date."
strInput = InputBox(Prompt:=strMsg, Title:="New Quarter Date",
XPos:=3000, YPos:=2000)
If strInput = "" Then
DoCmd.Hourglass False
Exit Sub
Else
qtrdate = strInput
DoCmd.Hourglass True
End If
On Error GoTo ErrorRoutine:
StartT = Time()
Set dbs = CurrentDb
'||||||||||||||||||||||||||||||||||||||||||||||||||
'Store new quarter date - this is used for many error and attendance
routines - do not modify.
Set rstDate = dbs.OpenRecordset("tblCompDate")
With rstDate
.MoveFirst
.Edit
!completedate = qtrdate
.Update
.Close
End With
'||||||||||||||||||||||||||||||||||||||||||||||||||
'clear table to hold records temporarily
dbs.Execute "delete * from tblNewQtr"
dbs.Execute "delete * from tblStudentHistNoRoll"
'isolate records - this copies the "end of quarter" records from expired
quarter
'to tblNewQtr so the records remaining in history can be reassigned for
'the next qtr. Get it? Rollover is coming up on the records that will roll
'for next qtr. Last qtr "end of quarter" records are stashed. They will
represent
'the archive records from last quarter, while the records requiring "rollover"
'are being modified for the new quarter.
'qryNewQtr takes care of that. The criteria for the query is simply "end of
quarter"
dbs.Execute "qryNewQtr"
'These are the records processed for "rollover"
sqlHist = "Select * from tblStudentHistory where active = -1"
Set rst = dbs.OpenRecordset(sqlHist)
rst.MoveLast
'start a progress bar
lngCount = rst.RecordCount
strMsgBar = "Processing...."
varReturn = SysCmd(acSysCmdInitMeter, strMsgBar, lngCount)
lngValue = 0
'start at the top
rst.MoveFirst
Do Until rst.EOF
'**********************************************************
'The rollover assumes a great deal. Most conspicuous is the assumption
'that courses, instructors, rooms, etc., did not change for next quarter.
rst.Edit
If left(rst!CourseNum, 3) = "ABE" And rst!Reason = "End of Quarter" Or _
left(rst!CourseNum, 3) = "ESL" And rst!Reason = "End of Quarter" Or _
left(rst!CourseNum, 3) = "GED" And rst!Reason = "End of Quarter" Then
If InstitutionMatch(rst!DocNumber, rst!INSTITUTION) Then
If NextQtrClass(qtrdate, rst!Rm, rst!Time, rst!CourseNum,
rst!SchedNum) Then
'While the rollover is in progress....
rst!AddDate = qtrdate
rst!DropDate = Null
rst!Reason = ""
rst!Instruct1 = gInstruct1
rst!Instruct2 = gInstruct2
rst!instruct3 = gInstruct3
rst!Quarter = nextQTR(rst)
rst!Active = -1
rst!Registered = 0
Else
rst!Active = 0
Call SavetoTable(rst, "tblStudentHistNoRoll")
End If
Else
rst!Active = 0
End If
'....might as well inactivate those records not participating in rollover
i.e., Basic Skills
'so they can be archived with the stashed "end of quarter" records
ElseIf rst!AddDate < qtrdate Then
rst!Active = 0
End If
rst!ChangedAt = Now()
rst!ChangedBy = gstrCurrentUser
rst.Update
'now let's retally credits and student status (stati)
Set rstStuUp = dbs.OpenRecordset("Select * from tblStudents where docnumber
='" & rst!DocNumber & "'")
Call ReTally(rstStuUp)
'Put the new quarter student updates (retallied above) where they can be
posted.
Set rstTemp = dbs.OpenRecordset("Select * from tblTransTemp where docnumber
= '" & rstStuUp!DocNumber & "'")
If rstTemp.EOF Then
rstTemp.ADDNEW
Else
rstTemp.Edit
End If
With rstTemp
!DocNumber = rstStuUp!DocNumber
![GED/HS] = rstStuUp![GED/HS]
!DATEASSIGNED = rstStuUp!DATEASSIGNED
!Assignment = rstStuUp!Assignment
!InmatePositionCode = rstStuUp!InmatePositionCode
!ExemptfromGWC = rstStuUp!ExemptfromGWC
!SupervisorCode2 = rstStuUp!SupervisorCode2
!StartDate = qtrdate
.Update
.Close
End With
rstStuUp.Close
rst.MoveNext
lngValue = lngValue + txtInc
If lngValue <= lngCount Then
varReturn = SysCmd(acSysCmdUpdateMeter, lngValue)
End If
Loop
varReturn = SysCmd(acSysCmdClearStatus)
varReturn = SysCmd(acSysCmdRemoveMeter)
beep
rst.Close
On Error GoTo ErrorRoutine
'Those records stashed to prevent new qtr updating can be inactivated.
dbs.Execute "UPDATE tblNewQTR SET Active = 0"
'At this point, ABE, ESL, and GED courses updated have rolled. All others
are inactive.
'The stashed records for archives are inactive and might as well join the rest
'so all inactive records can be archived.
Set rstSrc = dbs.OpenRecordset("tblNewQTR", dbOpenTable, dbForwardOnly)
If Not rstSrc.EOF Then
Set rstDest = dbs.OpenRecordset("tblStudentHistory", dbOpenDynaset,
dbAppendOnly)
Do While Not rstSrc.EOF
rstDest.ADDNEW
For Each fldSrc In rstSrc.Fields
rstDest(fldSrc.Name) = fldSrc.Value
Next
rstDest.Update
rstSrc.MoveNext
Loop
rstDest.Close
End If
rstSrc.Close
'***************************************************************************************
'Append arcStudentHistory and remove all inactive records from StuHist
'All that remains, then, are "rolled" and added classes. Note: The criteria
'for inactivating records was - if not basic skills that rolled or records
'with adddates = to the new qtr date then inactivate them. That means
'any courses that were added intended for the next quarter remain. So, one
'can add all the next quarter course assignments they want. They will still
be
'there when the dust settles on this procedure "Start New Quarter".
'Archive
'***************************************************************************************
'Update the student schedules - by the way - for those who rolled
'and, for the MI campus (an external, additional process as MI doesn't
'enroll students with EducationPro at this time.
dbs.Execute "UPDATE (tblStudents INNER JOIN [Inmate schedule] ON" _
& " tblStudents.DOCNumber = [Inmate schedule].DOCNumber) INNER JOIN" _
& " (tblStudentHistory INNER JOIN tblPrgrmCode ON" _
& " tblStudentHistory.PrgmCode = tblPrgrmCode.PrgrmCode) ON" _
& " tblStudents.DOCNumber = tblStudentHistory.DOCNumber SET [Inmate
schedule].Active = 'Y'" _
& " WHERE (((tblStudentHistory.Active)=-1) AND
((tblPrgrmCode.CategoryID)=1));"
'wspTrans.CommitTrans
startE = Time()
'It takes this long...
DoCmd.Hourglass False
MsgBox Format(startE - StartT, "H:mm:ss"), , "Elapsed time"
beep
'this is the end if to the post validation (disabled) process
'End If
ErrorRoutine:
DoCmd.Hourglass False
Select Case ERR.number
Case 3022
Resume Next
MsgBox ERR.Description & " " & ERR.number
Case 3021
Resume Next
Case Is > 0
MsgBox ERR.number & "@Report this one. Transaction will be cancelled.@" &
fldSrc.Name & ERR.Description
'Rollback
Exit Sub
End Select
'Set wspTrans = Nothing
beep
DoCmd.Hourglass False
Set dbs = Nothing
Set rst = Nothing
Set rstStuUp = Nothing
Set rstTemp = Nothing
Set wspTrans = Nothing
Set rstSrc = Nothing
Set rstDest = Nothing
End Sub
