Somebody sent me the incorrect code to get the list of active users of an mdb. I did corrections and it works OK now. Please send me a reference to the source of this code if you know it.
Option Compare Database
Option Explicit
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Type SecInfo
bMachine(1 To 32) As Byte
bSecurity(1 To 32) As Byte
End Type
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type BY_HANDLE_FILE_INFORMATION
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
dwVolumeSerialNumber As Long
nFileSizeHigh As Long
nFileSizeLow As Long
nNumberOfLinks As Long
nFileIndexHigh As Long
nFileIndexLow As Long
End Type
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
Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
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
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
Declare Function SetFilePointer Lib "kernel32" _
(ByVal hFile As Long, _
ByVal lDistanceToMove As Long, _
lpDistanceToMoveHigh As Long, _
ByVal dwMoveMethod As Long) As Long
Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
lpOverlapped As Any) As Long
Declare Function lread Lib "kernel32" Alias "_lread" (ByVal hFile As Long, _
lpBuffer As Any, ByVal wBytes As Long) As Long
Declare Function GetFileInformationByHandle Lib "kernel32" _
(ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long
Declare Function GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Dim mSecurity As SECURITY_ATTRIBUTES
Dim mFileHandle As Long
Dim mFileInfo As BY_HANDLE_FILE_INFORMATION
Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const OPEN_EXISTING = 3
Public Const FILE_BEGIN = 0
Public Const FILE_CURRENT = 1
Public Const FILE_END = 2
Public Function a_test()
Dim strPath As String
Dim strActiveUserList As String
strPath = CodeDb().Name
strPath = Mid(strPath, 1, InStr(1, strPath, ".") - 1) & ".ldb"
strActiveUserList = ReadLocks(strPath)
MsgBox strActiveUserList
End Function
Public Function ReadLocks(ByVal vstrDBPath As String) As String
Dim USecInfo As SecInfo
Dim aszTempUserList(0 To 254, 0 To 2) As String
Dim aszUserList() As String
Dim iaCnt As Integer
Dim iCnt As Integer
Dim iOffset As Integer
Dim lBytesRead As Long
Dim myoverlap As OVERLAPPED
Dim dwPos As Long
Dim lLock As Long
Dim lByte As Long
Dim strValueList As String
Dim lngRet As Long
With mSecurity
.nLength = Len(mSecurity)
.lpSecurityDescriptor = 0
.bInheritHandle = True
End With
mFileHandle = CreateFile( _
vstrDBPath, _
GENERIC_READ Or GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
mSecurity, _
OPEN_EXISTING, _
FILE_FLAG_RANDOM_ACCESS Or FILE_ATTRIBUTE_NORMAL, _
0)
If mFileHandle = 0 Then
MsgBox "Cannot open ldb"
ReadLocks = ""
Exit Function
End If
'lngRet = GetFileInformationByHandle(mFileHandle, mFileInfo)
SetFilePointer mFileHandle, 0, 0, FILE_BEGIN
iOffset = 0
iaCnt = 0
Do
'If ReadFile(mFileHandle, USecInfo, 64, lBytesRead, 0) = 0 Then
lBytesRead = lread(mFileHandle, USecInfo, 64)
If lBytesRead = 0 Then Exit Do
If lBytesRead <> 64 Then
MsgBox "error reading ldb"
ReadLocks = ""
Exit Function
End If
With USecInfo
aszTempUserList(iaCnt, 0) = szBytesToString(.bSecurity)
aszTempUserList(iaCnt, 1) = szBytesToString(.bMachine)
aszTempUserList(iaCnt, 2) = iOffset
End With
iaCnt = iaCnt + 1
iOffset = iOffset + 64
Loop
iaCnt = 0
dwPos = &H10000001
strValueList = "User name;Machine;"
Do Until dwPos = &H100000FF
lLock = LockFile(mFileHandle, dwPos, 0, 1, 0)
If lLock = 0 Then
lByte = lHexToLong(Right$(Hex(dwPos), 2))
iOffset = lByte * 64 - 64
For iaCnt = 0 To 254
If aszTempUserList(iaCnt, 2) = "" Then Exit For
If aszTempUserList(iaCnt, 2) = iOffset Then
strValueList = strValueList & _
aszTempUserList(iaCnt, 0) & ";" & _
aszTempUserList(iaCnt, 1) & ";"
End If
Next iaCnt
Else
lLock = UnlockFile(mFileHandle, dwPos, 0, 1, 0)
End If
dwPos = dwPos + 1
Loop
CloseHandle (mFileHandle)
ReadLocks = strValueList
End Function
Public Function szBytesToString(pbytArray() As Byte) As String
Dim szTemp As String
szTemp = StrConv(pbytArray(), vbUnicode)
szBytesToString = Left$(szTemp, (InStr(1, szTemp, Chr(0))) - 1)
End Function
Public Function lHexToLong(ByVal szHex As String) As Long
lHexToLong = Val("&H " & szHex & "&")
End Function
Copyright © 1999-2008 by Shamil Salakhetdinov. All rights reserved.