Reserved Error - 1104 - Works in 97 not in XP?

[beveritt]

Hi Everyone,

I've built a custom application for the company I work for that reads
each workgroup file for all the Access databases we support and
extracts each user and their corresponding login information and
inserts it into a table. Now, it works fine in Access 97, however, in
XP, I get the follwing error (Run-time Error #3000, Reserved Error
-1104, The is no message for this error.) It just about always crashes
when around 250 records are added to the table. I've hypothesized it
may have to do with the to many objects open at once. Does anyone have
any ideas? Here's my code:

Public Function getDBUsers()
On Error GoTo Err_getDBUsers

Dim db As DAO.Database
Dim rs_dbs As DAO.Recordset
Dim x As Integer

Set db = CurrentDb()
Set rs_dbs = db.OpenRecordset("Select * From qryAccessDatabases;")

rs_dbs.MoveLast
rs_dbs.MoveFirst

Do Until rs_dbs.EOF

Call getUserNames(rs_dbs!intDatabaseID, rs_dbs!Database,
rs_dbs!Workgroup, rs_dbs!strUserID, rs_dbs!strPassword)
rs_dbs.MoveNext

Loop

Exit_getDBUsers:

Set db = Nothing
Set rs_dbs = Nothing
Exit Function

Err_getDBUsers:

MsgBox "Error: " & Err.Number & Chr(13) & Chr(10) & Err.Description

Resume Exit_getDBUsers

End Function

Public Function getUserNames(db_id As Integer, db_database As String,
db_workgroup As String, db_userid As String, db_password As String)
On Error GoTo Err_getUserNames

Dim dbe As PrivDBEngine
Dim wrk As DAO.Workspace
Dim dbs As DAO.Database
Dim usr As DAO.User
Dim grp As DAO.Group
Dim User_ID As Long
Dim database_id As Long
Dim strUser As String
Dim strGroup As String
Dim password_blank As Boolean
Dim groups As String

Set dbe = New PrivDBEngine
dbe.SystemDB = db_workgroup
dbe.DefaultUser = db_userid
dbe.DefaultPassword = db_password

Set wrk = dbe.Workspaces(0)
Set dbs = wrk.OpenDatabase(db_database)

For Each usr In wrk.Users

strUser = usr.Name
groups = ""

password_blank = isBlankPassword(strUser)

For Each grp In wrk.groups
strGroup = grp.Name

If userInGroup(strUser, strGroup, wrk) = True Then
groups = groups & strGroup & ","
End If

Next grp

If groups <> "" Then
groups = Left(groups, Len(groups) - 1)
End If

Call addUser(strUser, db_id, groups, password_blank)

Next usr

Set dbe = Nothing

dbs.Close
Set dbs = Nothing

Exit_getUserNames:
Set dbs = Nothing
Exit Function

Err_getUserNames:
If Err.Number = 3028 Then
MsgBox "The following database has become corrupt or is missing.
User information cannot be obtained." & Chr(13) _
& Chr(13) & "Database: " & db_database _
& Chr(13) & "Workgroup: " & db_workgroup _
& Chr(13) & Chr(13) & "Repair this database and run this operation
again.", vbCritical + vbOKOnly, "Import Failed!"

Else

MsgBox "Error: " & Err.Number & Chr(13) & Chr(10) & Err.Description
End If

Resume Exit_getUserNames
End Function

Public Function userInGroup(user_name As String, group_name As String,
ByRef wrk As Workspace) As Boolean
On Error GoTo Err_userInGroup
Dim usr As User
Dim grp As Group

Set grp = wrk.groups(group_name)

For Each usr In grp.Users
If usr.Name = user_name Then
userInGroup = True
Exit Function
End If
Next usr

Exit_userInGroup:
Exit Function

Err_userInGroup:
MsgBox "Error: " & Err.Number & Chr(13) & Chr(10) & Err.Description

Resume Exit_userInGroup
End Function

Public Function isBlankPassword(user_name As String) As Boolean
On Error GoTo Err_isBlankPassword
Dim wrkTest As Workspace
Dim result As Boolean
Const errInvalidPassword = 3029

On Error Resume Next

Set wrkTest = DBEngine.CreateWorkspace("Test", user_name, "")
result = (Err = errInvalidPassword)

If result = True Then
isBlankPassword = False
Else
isBlankPassword = True
End If

Exit_isBlankPassword:
Exit Function

Err_isBlankPassword:
MsgBox "Error: " & Err.Number & Chr(13) & Chr(10) & Err.Description

Resume Exit_isBlankPassword

End Function

Public Function addUser(strUser As String, db_id As Integer,
db_permissions As String, isblank As Boolean)
On Error GoTo Err_addUser

Dim sql As String

sql = "INSERT INTO tblDBUsers ( database_id, strUserName,
strPermissions, blankPassword, [date] ) " _
& "SELECT " & db_id & " AS Expr1, '" & strUser & "' AS Expr2,
'" & db_permissions & "' AS Expr3, " & isblank & " AS Expr4, Now() AS
Expr5;"

DoCmd.RunSQL (sql)


Exit_addUser:

Exit Function

Err_addUser:
MsgBox "Error: " & Err.Number & Chr(13) & Chr(10) & Err.Description
End Function