Prevent new connections II

[Crystal]

Ok. I've copied the code from the Knowledge Base and it
seems to work, however. If I apply this to a database,
then try to open it on another machine, I don't get an
error and it lets me in. Is this what it's supposed to do?

Here is the code I used:

Sub ShowUserRosterAndPassiveShutdown()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim cn3 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim j As Long

On Error GoTo ErrHandler

cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=S:\Maintenance.mdb"

cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=S:\Maintenance.mdb"

' Restrict other users from opening the database
cn.Properties("Jet OLEDB:Connection Control") = 1

' Attempt to open another connection to the database
cn3.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=S:\Maintenance.mdb"

' The user roster is exposed as a provider-specific
' schema rowset in the Jet 4 OLE DB provider. You
have to use
' a GUID to reference the schema, as provider-specific
schemas
' are not listed in ADO's type library for schema
rowsets

Set rs = cn.OpenSchema(adSchemaProviderSpecific, , _
"{947bb102-5d43-11d1-bdbf-00c04fb92675}")

' Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name

Do While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Loop

' Close one of the remaining connections
cn2.Close

' Reopen the user roster to verify that no other users
are in the
' database Output the list of all users in the current
database.

Set rs = cn.OpenSchema(adSchemaProviderSpecific, , _
"{947bb102-5d43-11d1-bdbf-00c04fb92675}")

Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name

Do While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Loop

cn.Close

Exit Sub

ErrHandler:

For j = 0 To cn.Errors.Count - 1
Debug.Print "Conn Err Num : "; cn.Errors(j).Number
Debug.Print "Conn Err Desc: "; cn.Errors
(j).Description
Next j

For j = 0 To cn2.Errors.Count - 1
Debug.Print "Conn Err Num : "; cn2.Errors(j).Number
Debug.Print "Conn Err Desc: "; cn2.Errors
(j).Description
Next j

For j = 0 To cn3.Errors.Count - 1
Debug.Print "Conn Err Num : "; cn3.Errors(j).Number
Debug.Print "Conn Err Desc: "; cn3.Errors
(j).Description
Next j

Resume Next

End Sub

 

[Michel Walsh]

Hi,


Can you check that S, a map drive I presume, really point to the same physical database, for the
two PCs?

Why not using the \\PcName\path\maintenance.mdb" URL ? You forget to map a drive, or another
application want that letter S for another mapping, and you are done. URL don't have that problem
(unless you change the file server name, but then, the mapped drives are also in deep trouble).



Hoping it may help,
Vanderghast, Access MVP