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.