I need to add a LDB/LACCDB viewer on a client site, in order to check which are the users connected to an Access DB.
I have implemented such as follow (this code was made 10 years ago)
You call it like this and gives the result in a string (No = Not connected, but information kept in the ldb file. Yes = connected)
In the real project, I manage the string to send a message to the final users to close the application
I have implemented such as follow (this code was made 10 years ago)
You call it like this and gives the result in a string (No = Not connected, but information kept in the ldb file. Yes = connected)
In the real project, I manage the string to send a message to the final users to close the application
Code:
? Global_ReadAccessLockFile("D:\VB6\Test.ldb")
THIERRY(69.69.69.69):Admin ->NO
THIERRY(69.69.69.69):Admin ->YESCode:
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 10/11/2008
' * Module Name : LDB_Module
' * Module Filename : ldb.bas
' * Purpose :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Option Explicit
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject 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 GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const START_LOCK = &H10000001 ' *** Start of locks
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal sHostName As String) As Long
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Any, ByVal Length As Long)
Public Function Global_ReadAccessLockFile(Optional sFile As String = vbNullString) As String
' #VBIDEUtils#***********************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 10/11/2008
' * Module Name : LDB_Module
' * Module Filename : ldb.bas
' * Procedure Name : Global_ReadAccessLockFile
' * Purpose :
' * Parameters :
' * Optional sFile As String = vbNullString
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_HANDLER
Dim hFile As Long
Dim nReturn As Long
Dim nBytesRead As Long
Dim sComputer As String
Dim sUser As String
Dim nUsers As Long
Dim sUsersLock As String
sUsersLock = vbNullString
If LenB(sFile) = 0 Then GoTo EXIT_HANDLER
' *** Open file in protected mode
hFile = CreateFile(ByVal sFile, _
ByVal GENERIC_READ Or GENERIC_WRITE, _
ByVal FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, ByVal OPEN_EXISTING, ByVal 0&, ByVal 0&)
If hFile <> -1 Then
Do
nUsers = nUsers + 1
' *** Retrieve the computer name
sComputer = Space(32)
nReturn = ReadFile(hFile, ByVal sComputer, 32, nBytesRead, ByVal 0&)
sComputer = Left$(sComputer, InStr(sComputer, Chr(0)) - 1)
If (nReturn = 0) Or (nBytesRead = 0) Then Exit Do
' *** Retrieve the user name
sUser = Space(32)
nReturn = ReadFile(hFile, ByVal sUser, 32, nBytesRead, ByVal 0&)
sUser = Left$(sUser, InStr(sUser, Chr(0)) - 1)
If nReturn = 0 Or nBytesRead = 0 Then Exit Do
' *** Check if the user is still connected by lock the file, and log with computer name, IP adress and User name
If LockFile(hFile, START_LOCK + nUsers - 1, 0, 1, 0) = 0 Then
' *** An error occured, so it is still locked by the user
sUsersLock = sUsersLock & sComputer & "(" & Global_IPFromHostName(sComputer) & "):" & sUser & " ->YES" & vbCrLf
Else
' *** Nothing special, the user isn't locking
sUsersLock = sUsersLock & sComputer & "(" & Global_IPFromHostName(sComputer) & "):" & sUser & " ->NO" & vbCrLf
Call UnlockFile(hFile, START_LOCK + nUsers - 1, 0, 1, 1)
End If
Loop
CloseHandle hFile
End If
EXIT_HANDLER:
On Error Resume Next
Global_ReadAccessLockFile = sUsersLock
Exit Function
' #VBIDEUtilsERROR#
ERROR_HANDLER:
Resume EXIT_HANDLER
Resume
End Function
Public Function Global_IPFromHostName(sHostName As String) As String
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 10/11/2008
' * Module Name : LDB_Module
' * Module Filename : ldb.bas
' * Procedure Name : Global_IPFromHostName
' * Purpose :
' * Parameters :
' * sHostName As String
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_HANDLER
Dim nHostAdress As Long
Dim oHost As HOSTENT
Dim nHostIP As Long
Dim byIPAdress() As Byte
Dim nI As Long
Dim sIPAdress As String
nHostAdress = gethostbyname(sHostName)
If nHostAdress = 0 Then GoTo EXIT_HANDLER
CopyMemory oHost, nHostAdress, LenB(oHost)
CopyMemory nHostIP, oHost.hAddrList, 4
ReDim byIPAdress(1 To oHost.hLength)
CopyMemory byIPAdress(1), nHostIP, oHost.hLength
For nI = 1 To oHost.hLength
sIPAdress = sIPAdress & byIPAdress(nI) & "."
Next
sIPAdress = Mid$(sIPAdress, 1, Len(sIPAdress) - 1)
EXIT_HANDLER:
On Error Resume Next
Global_IPFromHostName = sIPAdress
Exit Function
' #VBIDEUtilsERROR#
ERROR_HANDLER:
Resume EXIT_HANDLER
Resume
End Function