code suddenly started locking the database

[simian336]

I have the following code I have been running for several days and it worked perfectly. Today everytime I run it, it locks the database and says I no longer have exclusive use. And I can't save any changes to the code.

The only change I have made was add a timing loop to give the xml parser more time.

Bacically this code just imports an xml file and numbers each record set so I can pivot it into a new table.

Any insites would be appreciated.

Thanks

Simi


On Error GoTo Err_Command0_Click

Label1.Caption = "Removing Tables"
Me.Repaint

DoCmd.SetWarnings False

'clear the tables
DoCmd.DeleteObject acTable, "Field"
DoCmd.RunSQL "Delete * from Document"
DoCmd.RunSQL "Delete * from SourceFile"

'create new table from saved table so you reset the autonumber field
DoCmd.RunSQL ("SELECT * INTO Field FROM _Field WHERE 1 = 2")

DoCmd.SetWarnings True

Label1.Caption = "Importing XML"
Me.Repaint

'append data because we want to use the existing sturcture with recno and id
Application.ImportXML _
DataSource:="E:\_ctz\Administrator_57_ee12e277_VS216EO.xml", _
ImportOptions:=acAppendData

'ctz 6/10/2010
' DataSource:="E:\_ctz\Administrator_57_3db26ed7_VRZ160G.xml", _
'CTZ 5/10/2011
' DataSource:="E:\_ctz\Administrator_57_ee12e277_VS216EO.xml", _

'DoCmd.RunSQL ("ALTER TABLE Field ADD COLUMN Recno long")

'******************************************************************
' xml parser is not finishing and needs extra time.
'******************************************************************
Label1.Caption = "Closing XML Parser"
Me.Repaint

Dim PauseTime, Start
PauseTime = 5 ' Set duration in seconds
Start = Timer ' Set start time.

Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop

'******************************************************************
'******************************************************************

Label1.Caption = "Updating Records"
Me.Repaint

'set max rec locs about the record count
DAO.DBEngine.SetOption dbMaxLocksPerFile, 50000

Dim dbs As Database
Dim rst As Recordset
Dim Counter As Long

' set up a updateable recordset of your table
Set dbs = Nothing

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SELECT * FROM field order by id", dbOpenDynaset)

Counter = 1
billnum = 0

' loop until run out of records
While Not rst.EOF
With rst
If rst.Fields(0).Name = "Name" And rst.Fields(0).Value = "Sys_DocName" Then
billnum = billnum + 1
End If
' sets your field to date for example
.Edit
![recno] = billnum
.Update
End With
'test
' moves to next record
rst.MoveNext

' one less record to go
Counter = Counter + 1
'Debug.Print Counter

'Let them know it is working update every 1000 records
If Counter Mod 1000 = 0 Then
Label1.Caption = Str(Counter) + " Completed!"
Me.Repaint
End If

' start loop again
Wend

Close #fnum
rst.Close
Set dbs = Nothing

Label1.Caption = "Import Finished"
Me.Repaint

Exit_Command0_Click:
Exit Sub

Err_Command0_Click:
MsgBox Err.Description
Resume Exit_Command0_Click

 

[vbajock]

Have tried hitting Ctrl/Break to see where the code stops when it is hung up? If it doesn't stop even if you hit Ctrl Break the Timer function and the parser may be having some sort of issue at a low level. If that is the case, you can use an older VB4 style timer. Put this function in a code module:


Public Function Vb4Timer(ByVal iTimelimit As Integer)
Dim dStart As Date 'start time
Dim dCurr As Date 'current time
Dim dt As Double 'delta time
Dim iTicks As Integer

dStart = Now()

Do
dCurr = Now() ' read current system time
dt = CDbl(dStart - dCurr) 'determine the diff between times
'and convert the difference DATE result to an integer value
iTicks = CInt(dt * 24 * 60 * 60) * -1 ' convert to total seconds
DoEvents
Loop Until iTicks = iTimelimit

End Function

Put this in your code where you want to pause

Call Vb4Timer(60) 'approx 1 minute

 

[vbajock]

One other thought, try commenting out the DoEvents if it still hangs, whatever event you are turning it over to may be what kicks off the low level bug in the parser as as well.

 

[simian336]

Thank you both for your suggestions. The delay code was the last piece of code that I worked on before it started locking the database a exection.

Unfortunatly I tried both your suggestions and no luck.

It never hangs, the program executes correctly, however once it finishes, I am no longer able to make change to or save the code or the form. It tells me I do not have exclusive use of the database (and it is local not on a server) so only I am using it. I have to close it comeback in then make changes.

Thanks for your ideas.

Simi

 

[PHV]

I'd replace this:
DAO.DBEngine.SetOption dbMaxLocksPerFile, 50000
with this:
Application.DBEngine.SetOption dbMaxLocksPerFile, 50000

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[simian336]

Hey PH,

That did not work either, but I liked it better so I kept it.

Wondering if there is a command to verify that the database is locked and I can use it to test the code at different points?

Thanks

MJ

 

[simian336]

Crazy!!!

The code was pretty linear so I decided to create a new button and start copying the code a few lines at a time, from the old button to the new button, until I got it to lock the database and it never did.

Exact same code and it did not lock the database.

Thats Crazy...


Simi

 

[vbajock]

Do you know how to step thru the code by pushing the F8 button? There is a FAQ here on how to debug your code. For now, tho, put a Stop statement as the first line in your procedure. Run it. When it hits the Stop (it will be highlighted) hit F8 to execute a line at a time, after each line executes hit Ctrl S to force a save, if you lost exclusive access the save will fail.

Are you certain you are not loading two instances of the database on the same machine? Also, what is the Close #fnum statement about? Get rid of it if you don't need it.

You can also try replacing Set dbs=CurrentDb with Set
dbs=
DBEngine.Workspaces(0).Databases(0)

Also, which ever method you use, make sure you cleanup your objects when your code completes:


Set rst = Nothing
Set dbs = Nothing