Access VBA Error 3211 "The database engine could not lock table"

Question

Access VBA Error 3211 "The database engine could not lock table"

Alex McIntyre 0

Access 2021 has just started giving '3211' errors on all of my databases when accessing a particular table. I'm a user, not a tech, so I'm lost.

It must be a generic permission setting in Access as it's affected all similar databases on the same table.

I've set the debug line in bold below.

Any help would be really appreciated.

The VBA code is:

Option Explicit

Option Compare Database

Private Sub BtnPrintPlayerList_Click()

Dim Response As Integer

Response = MsgBox("Do you want to show handicaps?", vbYesNoCancel)

Select Case Response

Case Is = vbYes

DoCmd.OpenReport "PlayersHandicapList", acViewReport

Case Is = vbNo

DoCmd.OpenReport "PlayersList", acViewReport

End Select

End Sub

Public Sub ButtonDisplayDraw_Click()

Dim SSEv As New ADODB.Recordset, SSM As New ADODB.Recordset, SSP As New ADODB.Recordset, SSEn As New ADODB.Recordset

Dim SSPrs As New ADODB.Recordset

Dim connDisDr As New ADODB.Connection

Set connDisDr = CurrentProject.Connection

SSEv.ActiveConnection = connDisDr

SSM.ActiveConnection = connDisDr

SSP.ActiveConnection = connDisDr

SSEn.ActiveConnection = connDisDr

SSPrs.ActiveConnection = connDisDr

Dim I As Integer, J As Integer, Col As Integer, Row As Integer, FirstRow As Integer, IncRow As Integer

Dim NEntries As Integer, NP2 As Integer, NRounds As Integer

Dim PID As Integer, PID1 As Integer, PID2 As Integer

Dim NL As Integer, MaxNL As Integer

Static PIDForDrawPos() As Integer

Static ResultforDrawPos() As String

Dim Xl As Excel.Application

Dim XlBook As Excel.Workbook

Dim XlSheet As Excel.Worksheet

Dim XLSheetName As String

Dim DrawPosName As String

Dim GridEntry As String

Dim Field1 As String, Field2 As String, tblRow1 As String, tblRow2 As String, tblValue1 As String, tblValue2 As String

Dim MySQL As String

' Get Details of Event

'Display SelectEvent form and move to selected record

DoCmd.OpenForm ("SelectEvent")

While SysCmd(acSysCmdGetObjectState, acForm, _

        "SelectEvent") = acObjStateOpen

  DoEvents 'Do Nothing Wait for Closing

Wend

If IsNull(SelEID) Then

MsgBox "No event selected", 48

Exit Sub

Else

SSEv.Open ("SELECT * FROM Events WHERE EID = " & CStr(SelEID))

If SSEv.BOF And SSEv.EOF Then

  MsgBox "Event ID not known in DisplayDraw", 48

  SSEv.Close

  Exit Sub

End If

End If

' Open Snapshots of Entries and Matches in Event

SSM.Open ("SELECT PID1, PID2, Result, WinDrawPos, MatchScore FROM Matches WHERE MatchOver = True And EID = " & CStr(SelEID))

SSEn.Open ("SELECT Count(*) As NEntries FROM Entries WHERE EID = " & CStr(SelEID))

NEntries = SSEn("NEntries")

SSEn.Close

SSP.Open ("SELECT ForeName, Surname, RTrim$(Forename) & ' ' & RTrim$(Surname) As Name, rtrim$(Initials) & Left$(Surname,1) As Tag, PID From Players"), , adUseClient, adOpenStatic

Retest:

Dim varTestTag As String

Dim strTestTag As String

Dim varMark As Variant

Dim strPlayer1 As String

Dim strPlayer2 As String

SSP.MoveFirst

Do While Not SSP.EOF

strPlayer1 = SSP("Name")

varMark = SSP.Bookmark

strTestTag = SSP("Tag")

SSP.Find ("Tag LIKE '" & strTestTag & "'"), 1, adSearchForward

If Not SSP.EOF Then

strPlayer2 = SSP("Name")

MsgBox "Player tags for " & strPlayer1 & " and " & strPlayer2 & " clash. Please edit the initials."

DoCmd.OpenForm "Player Data"

    While SysCmd(acSysCmdGetObjectState, acForm, _

                "Player Data") = acObjStateOpen

          DoEvents 'Do Nothing Wait for Closing

    Wend

    SSP.Requery

Exit Do

End If

SSP.Bookmark = varMark

SSP.MoveNext

Loop

If strPlayer2 <> "" Then

strPlayer2 = ""

GoTo Retest

End If

SSPrs.Open "SELECT * FROM DoublesPairs", , adOpenStatic

DrawGrids.DrawEventGrids

Set Xl = GetObject(, "Excel.Application")

Set XlBook = Xl.ActiveWorkbook

XLSheetName = SSEv("Tag")

Set XlSheet = XlBook.Worksheets(XLSheetName)

If SSEv("Type") <= ET_DrawAndProcess Then

' KO or Draw and Process

SSEn.Open ("SELECT PID, DrawPos FROM Entries WHERE EID = " & CStr(SelEID))

NP2 = 1

I = NEntries - 1

NRounds = 0

Do

  I = Int(I / 2)

  NP2 = NP2 * 2

  NRounds = NRounds + 1

Loop While I > 0



ReDim PIDForDrawPos(2 * NP2)

ReDim ResultforDrawPos(2 * NP2)

For I = 1 To NP2 * 2

  PIDForDrawPos(I) = 0

       ResultforDrawPos(I) = ""

Next

' Note Initial Positions and Calculate Col Width

  Do While Not SSEn.EOF

  PIDForDrawPos(SSEn("DrawPos")) = SSEn("PID")

  SSP.Filter = ("PID = " & CStr(SSEn("PID")))

 

  SSEn.MoveNext

Loop

   ' Note Results of any Matches

If Not (SSM.BOF And SSM.EOF) Then

SSM.MoveFirst

End If

Do Until SSM.EOF

  I = SSM("WinDrawPos")

  If I < 1 Or I > NP2 Then

    MsgBox "Invalid Winner Draw Position Found in Match Data: Match Ignored", 48

  Else

    PIDForDrawPos(I) = SSM("PID1")

    ResultforDrawPos(I) = SSM("MatchScore")

  End If

  SSM.MoveNext

Loop

' Finally Display the Results





  For J = 1 To NP2 * 2

    If PIDForDrawPos(J) > 0 Then

        If InStr(1, SSEv("Conditions"), "Doubles", 1) <> 0 Then

         'This is a Doubles event

         SSPrs.Filter = ("Player1PID = " & CStr(PIDForDrawPos(J)))

         DrawPosName = "DrawPos" & J

        GridEntry = SSPrs("PairName") & " " & ResultforDrawPos(J)

     Else

      SSP.Filter = ("PID = " & CStr(PIDForDrawPos(J)))

      DrawPosName = "DrawPos" & J

      GridEntry = SSP("Name") & " " & ResultforDrawPos(J)

      End If

        XlSheet.Range(DrawPosName).Formula = GridEntry

      

    End If

    

  Next

  

  For Col = 1 To NRounds + 1

  XlSheet.Columns(Col).AutoFit

  Next Col

Else ' Go on % wins

' Correct totals for number of wins

Dim DSTEn As New ADODB.Recordset

Dim SSTM As New ADODB.Recordset

Dim DSTempTable As New ADODB.Recordset

DSTEn.ActiveConnection = connDisDr

SSTM.ActiveConnection = connDisDr

DSTempTable.ActiveConnection = connDisDr



    

If SSEv("Type") = ET_Egyptian_KO_Plate Then

SSTM.Open ("SELECT PID1, PID2 FROM Matches WHERE (EID = " & CStr(SelEID) & " OR EID = " & CStr(SelEID - 1) & ") AND MatchOver = True)")

Else

  If SSEv("Type") = ET_Egyptian_DP_Plate Then

    SSTM.Open ("SELECT PID1, PID2 FROM Matches WHERE (EID = " & CStr(SelEID) & " OR EID = " & CStr(SelEID - 1) & " OR EID = " & CStr(SelEID - 2) & ") AND MatchOver = True)")

  Else

    SSTM.Open ("SELECT PID1, PID2 FROM Matches WHERE EID = " & CStr(SelEID) & " AND MatchOver = True")

  End If

End If



DSTEn.Open ("SELECT PID, Won, Played FROM Entries WHERE EID = " & CStr(SelEID)), , adOpenDynamic, adLockOptimistic



Dim Won As Integer, Lost As Integer

Do Until DSTEn.EOF

  PID = DSTEn("PID")

  SSTM.Filter = ("PID1 =" & CStr(PID))



  Won = 0

  Do Until SSTM.EOF

    Won = Won + 1

    SSTM.MoveNext

  Loop

  Lost = 0

  SSTM.Filter = ("PID2 =" & CStr(PID))

  Do Until SSTM.EOF

    Lost = Lost + 1

    SSTM.MoveNext

  Loop

  

  

  DSTEn("Won") = Won

  DSTEn("Played") = Won + Lost

  DSTEn.Update

  

  DSTEn.MoveNext

Loop



SSTM.Close

SSEn.Open ("SELECT PID, EID, Won, Played, DrawPos, ((Won / (Played + 0.00001))) As WinRatio FROM Entries WHERE EID = " & CStr(SelEID) & " ORDER BY (((Won + 0.0005) * 100 / (Played + 0.001))) DESC, DrawPos")

If SSEv("Type") = ET_American Then

  

    MySQL = "CREATE TABLE " & SSEv("Tag") & "("

    MySQL = MySQL & " [PID] Text,"

    MySQL = MySQL & " [PlayerName] text"



      Do Until SSEn.EOF

          SSP.Filter = ("PID = " & CStr(SSEn("PID")))

      

          MySQL = MySQL & ", [" & SSP("Tag") & "] text"

    

          SSEn.MoveNext

      Loop

    MySQL = MySQL & ", [Won] Text)"

    DoCmd.RunSQL MySQL

    

    DoCmd.SetWarnings False

    SSEn.MoveFirst

    Do Until SSEn.EOF

        SSP.Filter = ("PID = " & CStr(SSEn("PID")))

        MySQL = "INSERT INTO " & SSEv("Tag") & " (PID, PlayerName) "

        MySQL = MySQL & "VALUES (" & CStr(SSP("PID")) & ", '"

        MySQL = MySQL & SSP("Name") & "') "

       

        DoCmd.RunSQL MySQL

        SSEn.MoveNext

    Loop

 

  ' Now fill in results

    MySQL = "SELECT * FROM " & SSEv("Tag")





    DSTempTable.Open MySQL, , adOpenDynamic, adLockBatchOptimistic



    DSTempTable.MoveFirst



    Do Until DSTempTable.EOF

        SSM.Filter = ("PID1= " & DSTempTable("PID"))



        Do Until SSM.EOF

            SSP.Filter = ("PID=" & SSM("PID2"))

            Field1 = SSP("Tag")

            tblRow1 = SSM("PID1")

            tblValue1 = "'" & SSM("Result") & "'"

            If Field1 <> "" Then

                        MySQL = "UPDATE " & SSEv("Tag")

                        MySQL = MySQL & " SET [" & Field1 & "] = " & tblValue1

                        MySQL = MySQL & " WHERE PID= '" & tblRow1 & "'"

                        DoCmd.RunSQL MySQL

             End If

            SSM.MoveNext

        Loop



        SSM.Filter = ("PID2= " & DSTempTable("PID"))



        Do Until SSM.EOF

            SSP.Filter = ("PID=" & SSM("PID1"))

            Field1 = SSP("Tag")

            tblRow1 = SSM("PID2")

            tblValue1 = "'-" & Mid$(SSM("Result"), 2) & "'"

            If Field1 <> "" Then

                        MySQL = "UPDATE " & SSEv("Tag")

                        MySQL = MySQL & " SET [" & Field1 & "] = " & tblValue1

                        MySQL = MySQL & " WHERE PID= '" & tblRow1 & "'"

                        DoCmd.RunSQL MySQL

              End If

            SSM.MoveNext

        Loop



        DSTEn.Filter = ("PID = " & DSTempTable("PID"))

        tblRow2 = DSTempTable("PID")

        tblValue2 = CStr(DSTEn("Won"))

        MySQL = "UPDATE " & SSEv("Tag")

                    MySQL = MySQL & " SET Won = " & tblValue2

                    MySQL = MySQL & " WHERE PID= '" & tblRow2 & "'"

                    DoCmd.RunSQL MySQL

        DSTempTable.MoveNext

    Loop

    DSTempTable.UpdateBatch

    DSTempTable.Requery



    Dim fld As ADODB.Field

    Dim HeadingName As String

    Row = 4

    Col = 1



    For Each fld In DSTempTable.Fields

       HeadingName = fld.Name

       XlSheet.Cells(Row, Col).Formula = HeadingName

       Col = Col + 1

       Next fld

       

    XlSheet.Range("A5").CopyFromRecordset DSTempTable

    Xl.ErrorCheckingOptions.NumberAsText = False

    



    Dim obj As AccessObject

    For Each obj In Application.CurrentData.AllTables

'If the current table is named myTable…

    If obj.Name = SSEv("Tag") Then

    'and if MyTable is open (loaded)...

        If obj.IsLoaded Then

            '...close myTable

            DoCmd.Close acTable, obj.Name, acSaveNo

        End If

     DSTempTable.Close

    'Now delete the closed myTable table.

    DoCmd.DeleteObject acTable, obj.Name

     End If

    Next obj

    DoCmd.SetWarnings True

Else

Dim PName As String

Row = 3



Do Until SSEn.EOF

    Row = Row + 1

    SSP.Filter = ("PID = " & CStr(SSEn("PID")))

    If SSP("Forename") <> "" Then

        PName = SSP("Forename") & " " & SSP("Surname")

        Else

        PName = SSP("Initials") & " " & SSP("Surname")

    End If

    

    With XlSheet

        .Cells(Row, 1).Formula = PName

        .Cells(Row, 2).Formula = SSEn("Won")

        .Cells(Row, 3).Formula = SSEn("Played")

        .Cells(Row, 4).Formula = SSEn("WinRatio")

    End With

    

    SSEn.MoveNext

Loop



End If

End If

XlSheet.Activate

    XlSheet.Visible = True

    'Xl.Windows(1).Visible = True

   ' Xl.Windows(1).WindowState = xlMaximized

XlBook.Save

' DSTEn.Close

SSM.Close

SSEn.Close

SSEv.Close

SSP.Close

Set DSTempTable = Nothing

Set DSTEn = Nothing

Set SSM = Nothing

Set SSEn = Nothing

Set SSEv = Nothing

Set SSP = Nothing

connDisDr.Close

Set connDisDr = Nothing

End Sub

Private Sub ButtonDraw_Click()

Dim tbl As AccessObject, thisDB As Object

Set thisDB = Application.CurrentData

For Each tbl In thisDB.AllTables

'If the local table already exists...

If tbl.Name = "DrawTable" Then

  'If table is open...

  If tbl.IsLoaded Then

     '...close the table.

     DoCmd.Close acTable, "DrawTable", acSaveNo

  End If

'...delete the local table.

DoCmd.DeleteObject acTable, "DrawTable"

End If

Next tbl

CreateDraw.CreateDrawTable

End Sub

Private Sub ButtonEntries_Click()

'Click the 'Entries' button

DoCmd.OpenForm ("Entry Data")

End Sub

Private Sub ButtonEventResults_Click()

Dim MySQL As String

Dim SSM As New ADODB.Recordset

Dim SSEv As New ADODB.Recordset

Dim SSP As New ADODB.Recordset

Dim SSPrs As New ADODB.Recordset

Dim connRankRes As ADODB.Connection

Set connRankRes = CurrentProject.Connection

SSM.ActiveConnection = connRankRes

SSEv.ActiveConnection = connRankRes

SSP.ActiveConnection = connRankRes

SSPrs.ActiveConnection = connRankRes

Dim obj As AccessObject

For Each obj In Application.CurrentProject.AllReports

If obj.Name = "Event Results" Then

If obj.IsLoaded = True Then

 DoCmd.Close acReport, "Event Results", acSaveNo

End If

End If

Next obj

DoCmd.SetWarnings False

MySQL = "DELETE Results.* FROM Results"

DoCmd.RunSQL MySQL

DoCmd.OpenForm ("SelectEvent")

While SysCmd(acSysCmdGetObjectState, acForm, _

        "SelectEvent") = acObjStateOpen

  DoEvents 'Do Nothing Wait for Closing

Wend

SSP.Open ("SELECT (Rtrim(Initials) & ' ' & Rtrim(Surname)) AS Name, PID FROM Players"), , adOpenStatic, adLockOptimistic

SSEv.Open ("SELECT * FROM Events WHERE EID = " & CStr(SelEID)), , adOpenStatic, adLockOptimistic

SSM.Open ("SELECT PID1, PID2, Result FROM Matches WHERE EID = " & CStr(SelEID) & " AND State = " & CStr(MS_Finished) & " ORDER BY EndTime"), , adOpenStatic, adLockOptimistic

If SSEv("Conditions") Like "Doubles" Then

SSPrs.Open ("SELECT * FROM DoublesPairs"), , adOpenStatic, adLockOptimistic

Do Until SSM.EOF

    SSPrs.Filter = ("Player1PID = " & CStr(SSM("PID1")))

    MySQL = "INSERT INTO Results (Player1, Player2, Result) VALUES ('"

    MySQL = MySQL & SSPrs("PairName") & "', '"

    SSPrs.Filter = ("Player1PID = " & CStr(SSM("PID2")))

    MySQL = MySQL & SSPrs("PairName") & "', '" & SSM("Result") & "')"

    

    DoCmd.RunSQL MySQL

    



SSM.MoveNext

Loop

Else

Do Until SSM.EOF

    SSP.Filter = ("PID = " & CStr(SSM("PID1")))

    MySQL = "INSERT INTO Results (Player1, Player2, Result) VALUES ('"

    MySQL = MySQL & SSP("Name") & "', '"

    SSP.Filter = ("PID = " & CStr(SSM("PID2")))

    MySQL = MySQL & SSP("Name") & "', '" & SSM("Result") & "')"

    

    DoCmd.RunSQL MySQL

    



SSM.MoveNext

Loop

End If

DoCmd.SetWarnings True

DoCmd.OpenReport "Event Results", acViewReport

SSM.Close

SSEv.Close

SSP.Close

connRankRes.Close

Set SSM = Nothing

Set SSEv = Nothing

Set SSP = Nothing

Set connRankRes = Nothing

End Sub

Private Sub ButtonEvents_Click()

'Click the 'Events' button

DoCmd.OpenForm ("Event Data")

End Sub

Private Sub ButtonIndivRes_Click()

Dim MySQL As String

Dim SSM As New ADODB.Recordset

Dim SSEv As New ADODB.Recordset

Dim SSEn As New ADODB.Recordset

Dim SSP As New ADODB.Recordset

Dim BM As String

Static HSV(-6 To 49) As Integer

Static DiforSteps(-11 To 11) As Integer

Dim I

Dim Pos As Integer

Dim EID As Integer

Dim PID As Integer, PID1 As Integer, PID2 As Integer

Dim Hcap As Single, OHcap As Single, Hcap1 As Single, Hcap2 As Single

Dim Steps As Integer

Dim DeltaIndex As Integer

Dim Games As Integer

Dim Reply As String

Dim SReply As String

Dim connIndRes As ADODB.Connection

Set connIndRes = CurrentProject.Connection

SSM.ActiveConnection = connIndRes

SSEv.ActiveConnection = connIndRes

SSP.ActiveConnection = connIndRes

SSEn.ActiveConnection = connIndRes

Dim obj As AccessObject

For Each obj In Application.CurrentProject.AllReports

If obj.Name = "Individual Results" Then

If obj.IsLoaded = True Then

 DoCmd.Close acReport, "Individual Results", acSaveNo

End If

End If

Next obj

DoCmd.SetWarnings False

MySQL = "DELETE Results.* FROM Results"

DoCmd.RunSQL MySQL

DoCmd.OpenForm ("SelectPlayer")

While SysCmd(acSysCmdGetObjectState, acForm, _

        "SelectPlayer") = acObjStateOpen

  DoEvents 'Do Nothing Wait for Closing

Wend

'Initialise Handicap Tables

HSV(-6) = -21

HSV(-5) = -16

HSV(-4) = -12

HSV(-3) = -8

HSV(-2) = -5

HSV(-1) = -2

For I = 0 To 10

  HSV(I) = I

Next I

For I = 11 To 17

  HSV(2 * I - 11) = I

  HSV(2 * I - 10) = I

Next I

For I = 18 To 23

  HSV(4 * I - 47) = I

  HSV(4 * I - 46) = I

  HSV(4 * I - 45) = I

  HSV(4 * I - 44) = I

Next I

For I = 0 To 6

  DiforSteps(I) = 10 - I

  DiforSteps(-I) = 10 + I

Next I

For I = 7 To 8

  DiforSteps(2 * I - 7) = 10 - I

  DiforSteps(2 * I - 6) = 10 - I

  DiforSteps(-(2 * I - 7)) = 10 + I

  DiforSteps(-(2 * I - 6)) = 10 + I

Next I

DiforSteps(11) = 1

DiforSteps(-11) = 19

' For I = -4 To 48

' Debug.Print I, HSV(I)

' Next I

' For I = -11 To 11

' Debug.Print I, DiforSteps(I)

' Next I

SSP.Open ("SELECT PID, (RTrim(Forename) & ' ' & RTrim(Surname)) As Name, HCap FROM Players ORDER BY Surname, Forename"), , adOpenStatic, adLockOptimistic

PID = SelPID

BM = SSP.Bookmark

SSM.Open ("SELECT PID1, PID2, EID, Result FROM Matches WHERE (PID1 = " & CStr(PID) & " AND State=" & CStr(MS_Finished) & ") Or PID2 = " & CStr(PID) & " AND State=" & CStr(MS_Finished) & " ORDER BY EndTime"), , adOpenStatic, adLockOptimistic

SSEv.Open ("SELECT * FROM Events"), , adOpenStatic, adLockOptimistic

SSEn.Open ("SELECT PID, EID, Hcap From Entries"), , adOpenStatic, adLockOptimistic

TotalDI = 0

SSP.Filter = ("PID = " & CStr(SelPID))

Hcap = SSP("Hcap")

Do Until SSM.EOF

  EID = SSM("EID")

  PID1 = SSM("PID1")

  PID2 = SSM("PID2")

  SSEv.Filter = ("EID = " & CStr(EID))

   MySQL = "INSERT INTO Results (Event, wonLost, Player2, Handicap, Result, [H/L], IndexChange) VALUES ('"

    MySQL = MySQL & SSEv("Tag") & "', '"

    If PID1 = SelPID Then

        MySQL = MySQL & "beat', '"

        SSP.Filter = ("PID = " & CStr(PID2))

        MySQL = MySQL & SSP("Name") & "', '" & CStr(SSP("Hcap")) & "', '"

        MySQL = MySQL & CStr(SSM("Result")) & "', '"

     Else

        MySQL = MySQL & "lost to', '"

        SSP.Filter = ("PID = " & CStr(PID1))

        MySQL = MySQL & SSP("Name") & "', '" & CStr(SSP("Hcap")) & "', '"

        MySQL = MySQL & "-" & Mid$(SSM("Result"), 2) & "', '"

    End If

    

  

  If InStr(1, SSEv("Conditions"), "Handicap") > 0 Then

    MySQL = MySQL & "H', '"



  Else

    MySQL = MySQL & "L', '"

    

  End If

  

  If PID = PID1 Then

    SSP.Filter = ("PID=" & CStr(PID2))

' SSEn.FindFirst ("PID=" & CStr(PID2) & " AND EID=" & CStr(EID))

' Hcap2 = SSEn("HCap")

' Hcap = Hcap2

' SSEn.FindFirst ("PID=" & CStr(PID) & " AND EID=" & CStr(EID))

' Hcap1 = SSEn("Hcap")

     Hcap1 = Hcap

     Hcap2 = SSP("Hcap")

     OHcap = Hcap2

  Else

     SSP.Filter = ("PID=" & CStr(PID1))

' SSEn.FindFirst ("PID=" & CStr(PID1) & " AND EID=" & CStr(EID))

' Hcap1 = SSEn("Hcap")

' Hcap = Hcap1

' SSEn.FindFirst ("PID=" & CStr(PID) & " AND EID=" & CStr(EID))

' Hcap2 = SSEn("Hcap")

     Hcap1 = SSP("Hcap")

     OHcap = Hcap1

     Hcap2 = Hcap

  End If

  

  

  If InStr(1, SSEv("Conditions"), "Doubles", 1) = 0 Then

    ' This event counts

    If InStr(1, SSEv("Conditions"), "Handicap", 1) > 0 Then

      ' Handicap event

      If PID = PID1 Then

         DeltaIndex = 10

      Else

         DeltaIndex = -10

      End If

    Else

      ' This is level and gets messy.  Convert HCap to

      ' Notional step value

      Steps = HSV(Int(2 * Hcap2 + 0.001)) - HSV(Int(2 * Hcap1 + 0.001))

      If Abs(Steps) > 11 Then

        Steps = 11 * Sgn(Steps)

      End If

      If PID = PID1 Then

        DeltaIndex = DiforSteps(Steps)

      Else

        DeltaIndex = -DiforSteps(Steps)

      End If

    End If

    TotalDI = TotalDI + DeltaIndex

    If DeltaIndex >= 0 Then

      MySQL = MySQL & "+" & CStr(DeltaIndex) & "')"

    Else

      MySQL = MySQL & "-" & CStr(Abs(DeltaIndex)) & "')"

    End If

  

  DoCmd.RunSQL MySQL

  End If

  SSM.MoveNext

Loop





DoCmd.SetWarnings True

DoCmd.OpenReport "Individual Results", acViewReport

SSM.Close

SSEv.Close

SSP.Close

SSEn.Close

End Sub

Private Sub ButtonLawns_Click()

DoCmd.OpenForm ("Lawns Data")

End Sub

Private Sub ButtonMatches_Click()

'Click the 'Matches' button

DoCmd.OpenForm ("Match Data")

End Sub

Private Sub ButtonOrderOfPlay_Click()

DoCmd.OpenForm ("OrderOfPlay")

End Sub

Private Sub ButtonPlayers_Click()

'Click the 'Players' button

DoCmd.OpenForm ("Player Data")

End Sub

Private Sub ButtonPrtRankRes_Click()

Dim MySQL As String

Dim SSM As New ADODB.Recordset

Dim SSEv As New ADODB.Recordset

Dim SSP As New ADODB.Recordset

Dim connRankRes As ADODB.Connection

Set connRankRes = CurrentProject.Connection

SSM.ActiveConnection = connRankRes

SSEv.ActiveConnection = connRankRes

SSP.ActiveConnection = connRankRes

DoCmd.SetWarnings False

MySQL = "DELETE Results.* FROM Results"

DoCmd.RunSQL MySQL

SSP.Open ("SELECT (Rtrim(Initials) & ' ' & Rtrim(Surname)) AS Name, PID FROM Players"), , adOpenStatic, adLockOptimistic

SSEv.Open ("SELECT EID, Tag, Conditions FROM Events"), , adOpenStatic, adLockOptimistic

SSM.Open ("SELECT EID, PID1, PID2, Result FROM Matches WHERE State = " & CStr(MS_Finished) & " ORDER BY EndTime"), , adOpenStatic, adLockOptimistic

Do Until SSM.EOF

SSEv.Filter = ("EID = " & CStr(SSM("EID")))

If UCase(SSEv("Conditions")) = "ADVANCED SINGLES" Then

    SSP.Filter = ("PID = " & CStr(SSM("PID1")))

    MySQL = "INSERT INTO Results (Event, Player1, Player2, Result) VALUES ('"

    MySQL = MySQL & SSEv("Tag") & "', '" & SSP("Name") & "', "

    SSP.Filter = ("PID = " & CStr(SSM("PID2")))

    MySQL = MySQL & "'" & SSP("Name") & "', '" & SSM("Result") & "')"

    

    DoCmd.RunSQL MySQL

    

End If

SSM.MoveNext

Loop

DoCmd.SetWarnings True

DoCmd.OpenReport "Ranking Results", acViewReport

SSM.Close

SSEv.Close

SSP.Close

connRankRes.Close

Set SSM = Nothing

Set SSEv = Nothing

Set SSP = Nothing

Set connRankRes = Nothing

End Sub

Private Sub ButtonTournament_Click()

DoCmd.OpenForm "Tournament"

End Sub

Private Sub Form_Load()

Dim SST As New ADODB.Recordset

Dim connRepEvRes As ADODB.Connection

Set connRepEvRes = CurrentProject.Connection

SST.ActiveConnection = connRepEvRes

TryAgain:

SST.Open ("SELECT TName, TDate FROM Tournament"), , adOpenStatic, adLockOptimistic

If SST.EOF Then 'This must be a new tournament

DoCmd.OpenForm "Tournament"

While SysCmd(acSysCmdGetObjectState, acForm, _

        "Tournament") = acObjStateOpen

  DoEvents 'Do Nothing Wait for Closing

Wend

SST.Close

GoTo TryAgain

End If

With Me

.lblTitle.Caption = SST("TName") & " " & SST("TDate")

End With

SST.Close

connRepEvRes.Close

Set SST = Nothing

Set connRepEvRes = Nothing

End Sub

1 answer

Your answer

Answer 1

That error message, 3211, the database engine could not lock the table, indicates that the table is already being used by another process. Search for an open instance of Access which has a lock on that table, perhaps in a query or a bound form.

Check the back end accdb for your database applications. If the locking file (.laccdb) appears in the folder with the .accdb, even when you have closed your front end .accdb, that means some other .accdb somewhere is locking it. This may require assistance from your network admins to track it down unless you can personally deal with any possible users who might be the one who has it open.

Share via

Access VBA Error 3211 "The database engine could not lock table"

1 answer

Your answer