Retrieve a list of the users logged on to an Access-Jet Database

Option Explicit

'----------Type to hold results------------
'For each person who opens a shared database, the Jet database engine writes an entry
'in the database's .ldb file. The size of each .ldb entry is 64 bytes. The first 32
'bytes contains the computer name. The second 32 bytes contains the
'security name (such as Admin).
Private Type tDBUser
UserName As String * 32
SecurityName As String * 32
End Type


'Purpose : Retreives a list of users attached to an Access Database by parsing the ldb file
'Inputs : asUsers See outputs
' sLDBFilePath The path and file name of the ldb file
'Outputs : asUsers A 2d string array 1 to 2, 1 to Number of users
' Where asUsers(1,1) = First user name
' asUsers(2,1) = User's security access
' Returns 0 if their are no users or the lock file doesn't exist.
' Returns -1 on error.


Function DatabaseUsers(ByRef asUsers() As String, sLDBFilePath As String) As Long
Const clMaxUsers As Long = 255 'The maximum number of concurrent users that the Jet database engine supports is 255
Dim iFileNum As Integer
Dim tThisUser As tDBUser

On Error GoTo ErrFailed
If Len(Dir$(sLDBFilePath)) > 0 And Len(sLDBFilePath) > 0 Then
'Lock file exists, open file.
iFileNum = FreeFile
Open sLDBFilePath For Random As #iFileNum Len = Len(tThisUser)
'Create buffer to store results
ReDim asUsers(1 To 2, 1 To clMaxUsers)
'Read data into fixed length type
Get iFileNum, 1, tThisUser
Do While Not EOF(iFileNum)
DatabaseUsers = DatabaseUsers + 1
asUsers(1, DatabaseUsers) = Left$(tThisUser.UserName, InStr(1, tThisUser.UserName, vbNullChar) - 1)
asUsers(2, DatabaseUsers) = Left$(tThisUser.SecurityName, InStr(1, tThisUser.SecurityName, vbNullChar) - 1)
'Read next record
Get iFileNum, DatabaseUsers + 1, tThisUser
Loop
'Close file
Close #iFileNum
'Resize results
ReDim Preserve asUsers(1 To 2, 1 To DatabaseUsers)
Else
'No users attached
Erase asUsers
End If
Exit Function
ErrFailed:
DatabaseUsers = -1
Erase asUsers
End Function

'Demonstration routine
Sub Test()
Dim asUsers() As String, lNumUsers As Long, lThisUser As Long

lNumUsers = DatabaseUsers(asUsers, "D:\Work\Visual Basic\Net Send\NetSend.ldb")
For lThisUser = 1 To lNumUsers
Debug.Print "User Name: " & asUsers(1, lThisUser)
Debug.Print "Security : " & asUsers(2, lThisUser)
Next
End Sub