VBA to change maximum number of locks allowed on a recordset

[KPR1977]

Hi all. The code I run below runs perfectly in cases where I have a small amount of records. However, in cases were I have several thousands of records, the code only partially runs before giving me the error message of:

"File sharing lock exceeded. Increase MaxLocksPerFile registry entry."

"You have exceed the maximum number of locks allowed on a recordset. This limit is specified by the MaxLocksPerFile setting in your system registry.  The default value is 9500, and can be changed either by editing the registry or with the SetOption method."

For my case, the "SetOption method" sound like the way I want to go since I do not want to mess with my system registry. Does anyone know how to impliment this in my code below? Or maybe there's some simple refinements that need to be made to the code itself. I'm guess ADezii will probably land a solution. =)

As always, I so appreciate any suggestions. I attached a database with two modules that allow you to see the code working on a small set of records (modGo) and then failing on a large set of records (modNoGo).

Option Compare Database
Option Explicit
 
Public Function UpdateToMaster()
 
Dim updaterec As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
 
Dim Ctr As Integer
 
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT " & _
                          "PioCode, MdlYear, SRSER2, SRFMLY, SRDr, SRTRIM, SRTRAN, VMACCE, VMINT, VMEXT, SR, CM, fldupdated " & _
                          "FROM tblNoGo", dbOpenDynaset)
Set rs2 = db.OpenRecordset("SELECT " & _
                           "fldPIO, fldMdlYr, fldSeries, fldFamily, fldDr, fldTrim, fldTrans, fldAccGrp, fldIntClr, fldExtClr, fldSR, fldCM " & _
                           "FROM tblPioMaster", dbOpenDynaset)
 
rs.MoveFirst
rs2.MoveFirst
 
With rs2
 
   Do Until .EOF
      Do Until rs.EOF
 
      If rs!fldupdated = 0 Then
 
         updaterec = True
 
            For Ctr = 0 To 11  'Update this when adding additional criteria (e.g. 0-11 = 12 fields from MasterTable)
               If Not IsNull(.Fields(Ctr)) Then
                  If .Fields(Ctr) <> rs.Fields(Ctr) Then
                     updaterec = False
                        Exit For
                  End If
               End If
            Next Ctr
 
         If updaterec = True Then
            rs.Edit
               rs!PioCode = IIf(IsNull(!fldPIO), Null, !fldPIO)
               rs!MdlYear = IIf(IsNull(!fldMdlYr), Null, !fldMdlYr)
               rs!SRSER2 = IIf(IsNull(!fldSeries), Null, !fldSeries)
               rs!SRFMLY = IIf(IsNull(!fldFamily), Null, !fldFamily)
               rs!SRDr = IIf(IsNull(!fldDr), Null, !fldDr)
               rs!SRTRIM = IIf(IsNull(!fldTrim), Null, !fldTrim)
               rs!SRTRAN = IIf(IsNull(!fldTrans), Null, !fldTrans)
               rs!VMACCE = IIf(IsNull(!fldAccGrp), Null, !fldAccGrp)
               rs!VMINT = IIf(IsNull(!fldIntClr), Null, !fldIntClr)
               rs!VMEXT = IIf(IsNull(!fldExtClr), Null, !fldExtClr)
               rs!SR = IIf(IsNull(!fldSR), Null, !fldSR)
               rs!CM = IIf(IsNull(!fldCM), Null, !fldCM)
 
               rs!fldupdated = -1
            rs.Update
         End If
 
      End If
         rs.MoveNext
 
      Loop
           .MoveNext
         rs.MoveFirst
   Loop
 
End With
 
rs.Close
rs2.Close
 
Set db = Nothing
Set rs = Nothing
Set rs2 = Nothing
MsgBox "Worked!"
 
End Function

[NeoPa]

There are a few issues to deal with here :

1. I could find no reference to MaxLocksPerFile in the Help system. I specifically looked in SetOption.
2. SetOption seems to be a facility provided to change the options found under the Tools menu. I found nothing in there either related to this.
3. If this value were to be changed using this interface, then I expect the change made would change the registry. It would simply be doing it via a different interface.
4. Last, but certainly not least, if you have some code that needs this to be extended then there is a very good chance that the code should be looked at. The resources used for each lock are not trivial. If you have code that processes through recordsets without tidying itself up properly, then this is code that you want to change or otherwise lose. I hesitate to say throw away and start again, but I would give careful consideration to maintaining minimum locks during any piece of the code.

I don't suppose this is what you wanted to hear, but I'm afraid I'd be doing you no service if I'd left it unsaid.

[ADezii]

The good news is that the solution to your problem lies below, the bad news is that it only applies to the Current Session. Execute the following code 'prior' to executing your Function. Be sure to set the Reference to the DAO Object Library as indicated in the Comment. The Default Number of Locks Per File as defined by Jet is 9,500, the code will 'temporarily' increase this Value to 15000. This should be enough for your process to complete successfully. Let us know how you make out.

'Must first set a Reference to the Microsoft DAO X.X Object Library
DAO.DBEngine.SetOption dbMaxLocksPerFile, 15000

EXAMPLE

DAO.DBEngine.SetOption dbMaxLocksPerFile, 15000
 
Call UpdateToMaster

P.S. - The SetOption that you are referring to, and Referenced in the code, is the SetOption Method of the DBEngine Object NOT the Access Application Object.

[NeoPa]

On the other hand, if that's your code, then I don't see too many multi-level updates, and the .Edit is always matched by the .Update. It seems that Jet must be doing some kind of transaction management. It (Help) tells me that it doesn't, yet I can see no alternative. Clearly if it's maintaining the lock info it must be maintaing locks even after the .Update has been run.

If that is the case, I would consider handling the error and doing a Close and Reopen of your recordsets before continuing. You could simply increase the value of MaxLocksPerFile, but there will potentially be situations where even an increased one overflows. Closing and reopening does introduce a certain overhead, but not too onerous in such simple cases (I would consider opening the recordsets as Tables mind-you). Your code would need to handle continuing from where it left off though. This is not 100% straightforward when the tables have been closed between records.

[NeoPa]

@ADezii
Nice ADezii.

I suspect this is far more what the OP was after, and doesn't effect the registry (which is ideal for their purposes).

With that tip I was able to find the reference in Help for the method.

I'm curious to understand better why the code posted should have this problem though. It's actually pretty tidy as far as clearing down any resources goes. Perhaps one of the Access options specifies whether or not to treat such code as a massive transaction or not. Any ideas gratefully welcomed (BTW I see this as specifically relevant to this thread hence not reposting separately).

Your answer is clearly the best one for this thread's original question.

[ADezii]

This is a strange one NeoPa. This Error usually occurs when 1 or more Users are involved in Multiple Transactions within a Multi-User Environment. To make things stranger, I worked on the Database in work without setting the MaxLocksPerFile to 15000, and it worked flawlessly with the Default Setting of 9500. Same Access Version, comparative CPUs and Memory, etc. The only 'major' difference is that I'm networked in work, while at home I work on a Stand-a-Lone PC. Any ideas?

[KPR1977]

Thanks so much guys for responding and offering up insight into the dilemma I'm facing. ADezii, once again you knocked it out of the park! This line of code you offered was the key to overcoming the error message I was getting.

DAO.DBEngine.SetOption dbMaxLocksPerFile, 15000

I also see what you are saying about running it in a separate session. However, in order for it to work, I had to run it inside of my UpdateToMaster() function. On the downside, I'm unable to call anything else within the UpdateToMaster(), but if I create a seperate module, kind of like you suggested, it will allow me to run as many functions or routines as I need. =)

eg.

Module1

Public Function RunCodeProcesses()
Call UpdateToMaster
Call WorkedMsgBox
End Function
 

Module2

Option Compare Database
Option Explicit
 
Public Function UpdateToMaster()
DAO.DBEngine.SetOption dbMaxLocksPerFile, 15000
 
Dim updaterec As Boolean
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
 
Dim Ctr As Integer
 
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT " & _
                          "PioCode, MdlYear, SRSER2, SRFMLY, SRDOOR, SRTRIM, SRTRAN, VMACCE, VMINT, VMEXT, Sunroof, ConvMirror, fldupdated " & _
                          "FROM rawPIOapplications", dbOpenDynaset)
Set rs2 = db.OpenRecordset("SELECT " & _
                           "fldPIO, fldMdlYr, fldSeries, fldFamily, fldDoor, fldTrim, fldTrans, fldAccGrp, fldIntColor, fldExtColor, fldSunroof, fldConvMirror " & _
                           "FROM tblPioMaster", dbOpenDynaset)
 
rs.MoveFirst
rs2.MoveFirst
 
With rs2
 
   Do Until .EOF
      Do Until rs.EOF
 
      If rs!fldupdated = 0 Then
 
         updaterec = True
 
            For Ctr = 0 To 11  'Update this when adding additional criteria (e.g. 0-11 = 12 fields from MasterTable)
               If Not IsNull(.Fields(Ctr)) Then
                  If .Fields(Ctr) <> rs.Fields(Ctr) Then
                     updaterec = False
                        Exit For
                  End If
               End If
            Next Ctr
 
         If updaterec = True Then
            rs.Edit
               rs!PioCode = IIf(IsNull(!fldPIO), Null, !fldPIO)
               rs!MdlYear = IIf(IsNull(!fldMdlYr), Null, !fldMdlYr)
               rs!SRSER2 = IIf(IsNull(!fldSeries), Null, !fldSeries)
               rs!SRFMLY = IIf(IsNull(!fldFamily), Null, !fldFamily)
               rs!SRDOOR = IIf(IsNull(!fldDoor), Null, !fldDoor)
               rs!SRTRIM = IIf(IsNull(!fldTrim), Null, !fldTrim)
               rs!SRTRAN = IIf(IsNull(!fldTrans), Null, !fldTrans)
               rs!VMACCE = IIf(IsNull(!fldAccGrp), Null, !fldAccGrp)
               rs!VMINT = IIf(IsNull(!fldIntColor), Null, !fldIntColor)
               rs!VMEXT = IIf(IsNull(!fldExtColor), Null, !fldExtColor)
               rs!Sunroof = IIf(IsNull(!fldSunroof), Null, !fldSunroof)
               rs!ConvMirror = IIf(IsNull(!fldConvMirror), Null, !fldConvMirror)
 
               rs!fldupdated = -1
            rs.Update
         End If
 
      End If
         rs.MoveNext
 
      Loop
           .MoveNext
         rs.MoveFirst
   Loop
 
End With
 
rs.Close
rs2.Close
 
Set db = Nothing
Set rs = Nothing
Set rs2 = Nothing
 
 
End Function

Module3

Public Sub WorkedMsgBox()
MsgBox "Worked!  Thanks ADezii!!!!", vbExclamation, "Yay!!!"
End Sub

ADezii, I read your profile and I see that you were a Fire Fighter. Are you sure you didn't work for NASA, too??? Anyhow, I thank you for your service and I thank you for your solution. ;-)

[ADezii]

I think that I can also speak for NeoPa in that we were more than happy to assist you in this matter. Stop by again, should the need arise!

[NeoPa]

@ADezii
'Fraid not my friend. I'm a bit green when it comes to multi-user environments to be fair. I can sometimes think into it and come up with solutions, but it's not something I get into very often.

PS. Of course you speak for me. I was happy to provide what little insight I could on this subject.