The following code will show all users/PC IDs that are currently logged into a database.
Create a new form and use the code, you will also need to add a list box 'LoggedOn' and command button UpdateBtn etc.
Option Compare Database
Option Explicit
'Originally written for Access 2 by Mark Nally
'Revised an updated for Access 97 by:
'ATTAC Consulting Group
'http://ourworld.compuserve.com/homepages/attac-cg
'mailto:
75323.2112@Compuserve.com
'-----------------------------------------------------------------
'This Software was distributed as "Freeware" by the
'original author. ATTAC Consulting Group also is distributing
'this Software free of charge, for use by any developer or end user
'provided the attribution contained in the modules of the
'Software are maintained.
'This Software is provided "As Is" without warranty of any kind. ATTAC
'Consulting Group expressly disclaims any warrenty regarding
'merchantablity, performance or usability for any purpose whatsoever.
'ATTAC Consulting Group disclaims all liability for any damages,
'or loss including loss of data, or loss of business profits from use or inability
'to use the Software or any other pecuniary loss real, consequential or otherwise
'arrising in the course of use of this Software.
'--------------------------------------------------------------
' Declare a record type to break down the user info
Private Type UserRec
bMach(1 To 32) As Byte ' 1st 32 bytes hold machine name
bUser(1 To 32) As Byte ' 2nd 32 bytes hold user name
End Type
Private Sub cmdClose_Click()
On Error Resume Next
DoCmd.Close acForm, Me.FormName, acSaveNo
End Sub
Private Sub Form_Open(Cancel As Integer)
'Populate List box with who's logged on
Me.LoggedOn.RowSource = WhosOn()
End Sub
Private Sub UpdateBtn_Click()
'Populate List box with who's logged on when command button UpdateBtn is pressed
Me.LoggedOn.RowSource = WhosOn()
End Sub
'-------------------------------------------------------------------------------------
' Subject : WhosOn()
' Purpose : Will read *.LDB file and read who's currently
' logged on and their station name.
'
' The LDB file has a 64 byte record.
'
' The station name starts at byte 1 and is null
' terminated.
'
' Log-in names start at the 33rd byte and are
' also null terminated.
'
' I had to change the way the file was accessed
' because the Input() function did not return
' nulls, so there was no way to see where the
' names ended.
'-------------------------------------------------------------------------------------
Private Function WhosOn() As String
On Error GoTo Err_WhosOn
Dim iLDBFile As Integer, iStart As Integer
Dim iLOF As Integer, i As Integer
Dim sPath As String, x As String
Dim sLogStr As String, sLogins As String
Dim sMach As String, sUser As String
Dim rUser As UserRec ' Defined in General
Dim dbCurrent As Database
' Get Path of current database. Should substitute this code
' for an attached table path in a multi-user environment.
Set dbCurrent = DBEngine.Workspaces(0).Databases(0)
sPath = dbCurrent.Name
dbCurrent.Close
' Iterate thru dbCurrent.LDB file for login names.
sPath = "N:\Access_MDE_Runtime\QS_Testing_System\QS_Testing_System.ldb"
' Test for valid file, else Error
x = Dir(sPath)
iStart = 1
iLDBFile = FreeFile
Open sPath For Binary Access Read Shared As iLDBFile
iLOF = LOF(iLDBFile)
Do While Not EOF(iLDBFile)
Get iLDBFile, , rUser
With rUser
i = 1
sMach = ""
While .bMach(i) <> 0
sMach = sMach & Chr(.bMach(i))
i = i + 1
Wend
i = 1
sUser = ""
While .bUser(i) <> 0
'sUser = sUser & Chr(.bUser(i))
i = i + 1
Wend
End With
sLogStr = sMach & " -- " & sUser
If InStr(sLogins, sLogStr) = 0 Then
sLogins = sLogins & sLogStr & ";"
End If
iStart = iStart + 64 'increment to next record offset
Loop
Close iLDBFile
WhosOn = sLogins
Set dbCurrent = Nothing
Exit_WhosOn:
Exit Function
Err_WhosOn:
If Err = 68 Then
MsgBox "Couldn't populate the list", 48, "No LDB File"
Else
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
Close iLDBFile
End If
Resume Exit_WhosOn
End Function