A Microsoft Office (Excel, Word) forum. OfficeFrustration

If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below.

Go Back   Home » OfficeFrustration forum » Microsoft Access » General Discussion
Site Map Home Register Authors List Search Today's Posts Mark Forums Read  

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



 
 
Thread Tools Display Modes
  #1  
Old August 25th, 2005, 05:07 PM
beveritt
external usenet poster
 
Posts: n/a
Default Reserved Error - 1104 - Works in 97 not in XP?

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

 




Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

vB code is On
Smilies are On
[IMG] code is Off
HTML code is Off
Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
How do I convert works file to excel without works software? CatMB General Discussion 1 June 21st, 2005 04:12 PM
How do you open a Works 6.0 doc with Word 2002? capnhowdyox General Discussion 1 May 3rd, 2005 02:21 PM
Unable to install Word 2002 as a part of Microsoft Works Suite 20. Cindy M -WordMVP- General Discussion 0 April 26th, 2005 10:22 AM
VBA Code problem error 9 Speedy General Discussion 19 October 15th, 2004 09:05 PM
Works Vs. Office General Discussions 6 August 3rd, 2004 08:35 PM


All times are GMT +1. The time now is 08:28 AM.


Powered by vBulletin® Version 3.6.4
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 OfficeFrustration.
The comments are property of their posters.