DWUTKA at marlow.com
DWUTKA at marlow.com
Wed May 18 11:45:38 CDT 2005
Paste the following code into a class module called DBUsers
Option Compare Database
Option Explicit
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA"
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal
dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal
dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal
hTemplateFile As Long) As Long
Private Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, ByVal
dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal
nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long) As
Long
Private Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long,
ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal
nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long)
As Long
Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long)
As Long
Dim LDBUsers As Collection
Dim DatabasePath As String
Dim strFirstTwoBytesOfHeaderPage As String
Property Get CurrentUser() As Long
Dim dwReturn As Long
Dim hFile As Long
Dim sa As SECURITY_ATTRIBUTES
Dim i As Long
hFile = CreateFile(Left(CurrentDb.Name, Len(CurrentDb.Name) - 3) & "ldb" &
Chr(0), GENERIC_READ, FILE_SHARE_READ + FILE_SHARE_WRITE, sa, OPEN_EXISTING,
0, 0)
For i = 268435457 To 268435711
dwReturn = LockFile(hFile, i, 0, 1, 0)
If dwReturn > 0 Then
'CheckLock = False
dwReturn = UnlockFile(hFile, i, 0, 1, 0)
Else
'Let's try to unlock it.
dwReturn = UnlockFile(hFile, i, 0, 1, 0)
CurrentUser = i - 268435456
End If
Next i
dwReturn = CloseHandle(hFile)
End Property
Property Get LDBUserCount()
LDBUserCount = LDBUsers.Count
End Property
Property Get ActiveUserCount()
Dim i As Long
Dim dui As DBUserInfo
i = 0
For Each dui In LDBUsers
If dui.UserActive Then i = i + 1
Next
ActiveUserCount = i
End Property
Property Get ActiveUserInfo(intPos) As DBUserInfo
Dim i As Long
Dim dui As DBUserInfo
i = 0
For Each dui In LDBUsers
If dui.UserActive Then i = i + 1
If i = intPos Then
Set ActiveUserInfo = dui
Exit For
End If
Next
Set dui = Nothing
End Property
Property Get DBUserInformation(intPos) As DBUserInfo
Set DBUserInformation = LDBUsers(intPos)
End Property
Public Function RefreshData()
Set LDBUsers = New Collection
GetLDBUsers
End Function
Private Function CheckLock(strPath As String, intByte As Long) As Boolean
Dim dwReturn As Long
Dim hFile As Long
Dim sa As SECURITY_ATTRIBUTES
hFile = CreateFile(Left(CurrentDb.Name, Len(CurrentDb.Name) - 3) & "ldb" &
Chr(0), GENERIC_READ, FILE_SHARE_READ + FILE_SHARE_WRITE, sa, OPEN_EXISTING,
0, 0)
dwReturn = LockFile(hFile, intByte, 0, 1, 0)
If dwReturn > 0 Then
CheckLock = False
dwReturn = UnlockFile(hFile, intByte, 0, 1, 0)
Else
CheckLock = True
End If
dwReturn = CloseHandle(hFile)
End Function
Private Function GetLDBUsers()
On Error GoTo ErrorHandler
Dim strPath As String
Dim strData As String
Dim strTemp As String
Dim strHeaderData As String
Dim f As Long
Dim li As DBUserInfo
Dim i As Long
Dim intPos As Long
strPath = Left(DatabasePath, Len(DatabasePath) - 3) & "ldb"
strTemp = Dir(strPath)
If strTemp <> "" Then
f = FreeFile
strHeaderData = Space(512)
Open DatabasePath For Binary Access Read As f
Get f, 1537, strHeaderData
Close f
f = FreeFile
Open strPath For Binary Access Read As f
strData = Space(LOF(f))
Get f, , strData
Close f
strFirstTwoBytesOfHeaderPage = Left(strHeaderData, 2)
strHeaderData = Mid(strHeaderData, 3)
i = 1
Do Until strData = ""
Set li = New DBUserInfo
strTemp = Left(strData, 32)
strData = Mid(strData, 33)
li.PositionNumber = i
intPos = InStr(1, strTemp, Chr(0), vbBinaryCompare)
If intPos > 0 Then
li.ComputerName = Left(strTemp, intPos - 1)
Else
li.ComputerName = strTemp
End If
strTemp = Left(strData, 32)
If Len(strData) > 32 Then
strData = Mid(strData, 33)
Else
strData = ""
End If
intPos = InStr(1, strTemp, Chr(0), vbBinaryCompare)
If intPos > 0 Then
li.AccountName = Left(strTemp, intPos - 1)
Else
li.AccountName = strTemp
End If
li.HeaderBytes = Mid(strHeaderData, (i * 2) - 1, 2)
li.UserActive = CheckLock(strPath, 268435456 + i)
LDBUsers.Add li
Set li = Nothing
i = i + 1
Loop
GetLDBUsers = "Done"
Else
GetLDBUsers = "NoLDB"
End If
Exit Function
ErrorHandler:
GetLDBUsers = Err.Number & " " & Err.Description
Err.Clear
End Function
Private Sub Class_Initialize()
DatabasePath = CurrentDb.Name
End Sub
Then paste the following code into a class called DBUserInfo:
Option Compare Database
Option Explicit
Public PositionNumber As Long
Public ComputerName As String
Public AccountName As String
Public HeaderBytes As String
Public UserActive As Boolean
Property Get FirstHeaderByte()
FirstHeaderByte = Asc(Left(HeaderBytes, 1))
End Property
Property Get SecondHeaderByte()
SecondHeaderByte = Asc(Right(HeaderBytes, 1))
End Property
You can use these two classes to see who is active in an .mdb.
Drew
-----Original Message-----
From: Marcel Vreuls [mailto:vrm at tim-cms.com]
Sent: Wednesday, May 18, 2005 8:07 AM
To: 'Access Developers discussion and problem solving'
Subject: [AccessD] Multiuser
Hi all,
I am wondering if there are people out there of have ever thought or have a
solution how to solve a multiuser problem. I have updated our app so
multiuser and recordlocking should be no problem anymore.
Now I am looking for a way how to see how many users are logged in at a
certain time and perhaps show those users. The way is I guess read the ldb
file. But is there a way to make sure users not logged in are not anymore in
the ldb file?
Thanks for your info,
Marcel
--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com