Well, good news. I have the logic at least running and yet to be tested fully but it seems to be generating something akin to sensible results . My last challenge now is how to implement Rollback and Commit. I looked around and got a bit confused by seemingly conflicting examples. In the end I used the dbengine.begintrans , .rollback and .commit methods but it failed in the code below after the first instance of dbengine.rollback on the line intClubID = rs1![RaceClub] with error ' No Current record'. I am assuming that the dbengine.rollback method has discarded the current record marker so I commented them out for now. Am I correct in this assumption because if it is that's a pain as it is going to be difficult to set the current record marker in the recordset since it is generated by a query. I'm hoping that there is some clever way of resetting (or storing) the current record marker. The recordset I am looping through, rs1, I am also updating as I go along and it is these updates I want to roll back if there are not enough runners/athletes for the team. I still want to continue reading through the rs1 recordset of course to create any more potential teams. Do I then need another recordset for the underlying table of rs1 that I update directly because of the affect Rollback has on the current record marker?
Thanks as ever for any guidance. I've put the code below in case it helps:
Private Sub btnCalculateRaceEventTeamResults_Click()
'On Error GoTo ErrorHandler
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim rs4 As DAO.Recordset
Dim sqlString As String
Dim intTeam As Integer ' Holds the number representing the team 0=A, 1=B, 2=C etc
Dim intTeamID As Integer ' The table "Team" primary key
Dim intTeamTotPos As Integer
Dim intTeamTotSecs As Integer
Dim intTeamCounter As Integer ' How many in the current team
Dim strTeamGender As String
Dim intMaxTeamCounter As Integer
Dim intClubID As Integer
'Make sure a race has been selected
If IsNull(Forms!frmPrintRaceEventTeamResults!cmbRaceName) Or IsNull(Forms!frmPrintRaceEventTeamResults!cmbRaceDate) Then
intAnswer = MsgBox("Please select a valid race", vbCritical)
Exit Sub
End If
intAnswer = MsgBox("You are about to recalculate the team results for this event. Doing so will remove all previous results. Do you wish to Continue", _
vbQuestion + vbYesNo)
'Exit if they don't want to continue
If Not (intAnswer = vbYes) Then
Exit Sub
End If
DoCmd.SetWarnings (WarningsOff) 'This avoids confusing messages to the user that 'n' records will be being updated (or not!)
Set db = CurrentDb()
'First remove all the records for this race event that might have been previously calculated
DoCmd.OpenQuery "qryDeleteRaceEventTeamResults"
Set rs1 = fDAOGenericRst("qryRaceEventTeamResultsIndividual")
'Now read the Team table firsst to get the criteria for the teams
'Then read through the database doing first the teams for the women gender = 'F' and then the men 'M' gender = 'M'
'Write a team record for each set of male or female runners qualify for the team criteria
'Mixed teams will be dealt with later
'If the race is part of a series the series team criteria will take precedence over the race event team criteria
'If there are no records to process just end here
If rs1.EOF Then
intAnswer = MsgBox("There are no records to process for this Event", vbCritical)
Exit Sub
End If
'Read the RaceEvent or Series record to get the Team calclation ID
If rs1![RaceSeries] = 0 Then
sqlString = "SELECT * FROM [RaceEvent] WHERE [ID] = " & rs1![RaceEvent]
Set rs3 = db.OpenRecordset(sqlString, dbOpenDynaset)
rs3.MoveLast 'this will "populate the recordset"
intTeamID = rs3![RaceEventTeamID]
Else
sqlString = "SELECT * FROM [Series] WHERE [SeriesID] = " & rs1![RaceSeries]
Set rs3 = db.OpenRecordset(sqlString, dbOpenDynaset)
rs3.MoveLast 'this will "populate the recordset"
intTeamID = rs3![SeriesTeamID]
End If
'Now read the team table to get the correct criteria
sqlString = "SELECT * FROM [Team] WHERE [TeamID] = " & intTeamID
Set rs4 = db.OpenRecordset(sqlString, dbOpenDynaset)
rs4.MoveLast 'this will "populate the recordset"
rs1.MoveLast 'this will "populate the recordset"
rs1.MoveFirst
'Loop through the runners for the raceevent for each gender to calculate totals for each runner in the team
'Females are first in alphabetical sequence
'Increment the team ID for each new team
intTeamTotPos = 0
intTeamTotSecs = 0
intTeamCounter = 0
intTeam = 0
strTeamGender = rs1![RaceGender]
intClubID = rs1![RaceClub]
If rs1![RaceGender] Like "F" Then
intMaxTeamCounter = rs4![NumOfFemaleAthletes]
Else
intMaxTeamCounter = rs4![NumOfMaleAthletes]
End If
Set rs2 = db.OpenRecordset("TeamResults")
Do While Not rs1.EOF
If Not strTeamGender Like rs1![RaceGender] Or Not intClubID = rs1![RaceClub] Then
' DBEngine.Rollback ' Undo any changes so far as there are not enough runners to form a team
intTeamTotPos = 0
intTeamTotSecs = 0
intTeamCounter = 0
intTeam = 0
intClubID = rs1![RaceClub]
If Not strTeamGender Like rs1![RaceGender] Then
intMaxTeamCounter = rs4![NumOfMaleAthletes]
strTeamGender = rs1![RaceGender]
End If
End If
'DBEngine.BeginTrans 'All database reads and writes will be held until 'Committed'
intTeamCounter = intTeamCounter + 1
intTeamTotPos = intTeamTotPos + rs1![RaceGenderPosition]
intTeamTotSecs = intTeamTotSecs + rs1![RaceTimeSecs]
With rs1
.Edit
![RaceTeam] = intTeam
.Update
End With
If intTeamCounter = intMaxTeamCounter Then
'Insert the team record
With rs2
.AddNew
![TeamSeriesID] = rs1![RaceSeries]
![TeamRaceEventID] = rs1![RaceEvent]
![TeamClubID] = rs1![RaceClub]
![TeamGender] = strTeamGender
![Team] = intTeam
![TeamTotPos] = intTeamTotPos
![TeamTotSecs] = intTeamTotSecs
.Update
End With
'DBEngine.CommitTrans 'Commit the database changes so they are permanent and consistent
intTeamCounter = 0
intTeamTotPos = 0
intTeamTotSecs = 0
intTeam = intTeam + 1
End If
rs1.MoveNext
Loop
DoCmd.SetWarnings (WarningsOn)
Error_Handler_Exit:
On Error Resume Next
If Not rs1 Is Nothing Then
rs1.Close
Set rs1 = Nothing
End If
If Not rs2 Is Nothing Then
rs2.Close
Set rs2 = Nothing
End If
If Not rs3 Is Nothing Then
rs3.Close
Set rs3 = Nothing
End If
If Not rs4 Is Nothing Then
rs4.Close
Set rs4 = Nothing
End If
If Not db Is Nothing Then Set db = Nothing
Exit Sub
ErrorHandler:
'DBEngine.Rollback
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: cmd_AddRec_Click" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
