How to read amount of users in ldb file

[Pete666]

I have an automatic compact function for an Access 97 database which works fine but I would like the function to only run when there is only 1 person accessing the database.

It is currently on exiting the database the users will be prompted with a yes no to the compact function, but I only want this to be visible when they are the only user accessing it.




Thanks

 

[Pete666]

Please note this is an Access 97 database.

 

[DCrake]

Simple Software Solutions

These sample functions are used in VB and Access. I use this to count the number of "bums on seats" when a user opens a front end application. The reason being that there can be any number of installations on a network but only x amount of user can be logged in at any one time (licenses).

The code could be manipulated to suit your own needs but the functionality should suffice.

Function CountConnectionInUse()


'Read the registry setting to determine where the back end was installed to.

Call GetSysDataPath


'check to see if the target database exists or has been moved.
If Dir(SysDataPath & "\[B]YourDatabaseName[/B].MDB") = "" Then
    MsgBox "Cannot find the source database." & vbCrLf & vbCrLf & "Unable to connect to " & UCase(SysDataPath) & "\YourDatabaseName.MDB. Please check that the file exists in the specified location. " & vbCrLf & vbCrLf & IIf(Left(SysDataPath, 1) <> "C", "Check network connection via My Computer.", "") & vbCrLf & vbCrLf & "Application will terminate once you click the Ok button.", vbCritical + vbOKOnly, "Cannot detect database"
    End ' teminate application
End If
    
Dim BumsOnSeats As Integer
Dim szMaxUsers As Integer
    szMaxUsers = 15
    
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    ' Open the connection
    With cn
      .Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
         "Data Source=" & SysDataPath & "\[B]YourDatabaseName.mdb[/B]"
    End With
    'You have to take off 1 user as you are part of the count
    BumsOnSeats = CountUsers(cn) - 1
    Set cn = Nothing
    If BumsOnSeats >= szMaxUsers Then
        If szMaxUsers > 1 Then
            MsgBox "There are aready " & szMaxUsers & " users logged into the application." & vbCrLf & vbCrLf & "Please wait while another user logs out before attempting to log in again.", vbExclamation + vbOKOnly, "Maximum number of concurrent users reached."
        Else
            MsgBox "There is aready 1 user logged into the application." & vbCrLf & vbCrLf & "Please wait while this user logs out before attempting to log in again.", vbExclamation + vbOKOnly, "Maximum number of concurrent users reached."
        End If
        
        End ' teminate application
    End If
    
        
    
   
End Function

Function GetSysDataPath() 
'This function reads the registry to obtain the path to the back end database
'and stores it in a public variable called SysDataPath

        RegValue = "HKEY_LOCAL_MACHINE\SOFTWARE\[B]XZYsoftware[/B]\[B]BackEnd[/B]\DataPath"
        SysDataPath = CreateObject("WScript.Shell").RegRead(RegValue)
 
End Function

Function CountUsers(cn As ADODB.Connection)
    Dim rs          As ADODB.Recordset


    ' The user roster is exposed as a provider-specific schema rowset
    ' in the Jet 4.0 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}")

    CountUsers = 0
    With rs
        Do Until .EOF
            CountUsers = CountUsers + 1
            .MoveNext
        Loop
    End With
     
    rs.Close
    Set rs = Nothing


End Function

CodeMaster:

 

[mattkorguk]

Hi,
I went down a slightly different route of capturing users details as they open the database, see below.
I have a Usage table which stores their details and also a lookup table of known users which has a [security] field, this is used to allow access to reports, or not.

 DoCmd.SetWarnings False
    Dim oNet, ocomp As Object
    Set oNet = CreateObject("WScript.Network")
    Set ocomp = CreateObject("WScript.Network")
    UserName = oNet.UserName
    computername = ocomp.computername
    If (IsNull(DLast("[LoggedOut]", "Usage", "[UserName] ='" & Me.UserName & "'"))) Then
            If MsgBox("Please remember to close the BDatabase using the 'Exit' button" & Chr(13) & Chr(10) & "Thank you for your co-operation.", vbInformation, "Info") = vbOK Then
            End If
    End If
    DoCmd.OpenQuery "qryUpdateUsage", acViewNormal
        If (IsNull(DLookup("[Name]", "BDUsers", "[Login ID] ='" & Me.UserName & "'"))) Then
            Me.Caption = "UNKNOWN USER - Welcome to the BDatabase"
            Me.security = 777
        Else
            Me.Caption = DLookup("[Name]", "BPDUsers", "[Login ID] ='" & Me.UserName & "'") & " - Welcome to the BP Database"
            Me.security = DLookup("[Security]", "BDUsers", "[Login ID] ='" & Me.UserName & "'")
        End If
    DoCmd.SetWarnings False
    Dim db As DAO.Database
    Dim snp As DAO.Recordset
    Dim msg As String
    Set db = CurrentDb
    Set snp = db.OpenRecordset("Settings", dbOpenSnapshot)
        If snp![Logoff] Then
            If Me.security = 999 Then
                MsgBox "Welcome Admin", vbOKOnly, "You're in!"
            Else
            msg = "The database is currently closed for updating" & vbCrLf & vbCrLf & vbTab & _
            "Please try later." & vbCrLf & vbTab & "Thank you." & vbCrLf & "Matthew King" & vbCrLf & "(7100 5034)"
            MsgBox msg
            Application.Quit
        End If
        End If
    Me.frmNotification_Count.Visible = security
    Me.frmOutstandingCount.Visible = security
    Me.cmdMaint.Visible = security
    Me.cmdRefresh.Visible = security
    DoCmd.Hourglass False
    DoCmd.SetWarnings True

I have also blocked the close 'X', so users have to use the Exit button on the front screen. This runs a query to update the Usage table with the logged out date/time.
Others may notice that I've included some tips found on this site for auto logging users out, there's an on timer event running.

Private Sub Form_Timer()
    Dim db As DAO.Database
    Dim snp As DAO.Recordset
    Dim msg As String, intLogoff As Integer
    Set db = CurrentDb
    Set snp = db.OpenRecordset("Settings", dbOpenSnapshot)
    intLogoff = snp![Logoff]
    snp.Close
    db.Close
    If intLogoff = True Then
        If Me.security = 999 Then
            Exit Sub
        Else
            If Me.Tag = "MsgSent" Then
                DoCmd.TransferText acExportDelim, , "qryClosed", "C:\BD\" & "Closed.txt"
                Me.Refresh
                Dim RetVal
                RetVal = Shell("C:\Windows\notepad.exe C:/BD/closed.txt", 1)
                Application.Quit (acQuitSaveAll)
            Else
                Me.Tag = "MsgSent"
                DoCmd.OpenForm "frm_ExitNow"
            End If
        End If
    End If
End Sub

If I kick users out I'm creating a text box which then opens on their machines informing them when and why they were kicked out. The database remains unusable until the [Settings] option is updated.
I hope that gives you a few things to think about. If you have any questions about the code above, please let us know.
I've seen some .ldb files which can't be read, just a lot of jumbled images, although ours here logs the users machine ID, which can be very useful.