1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
| Option Explicit
Private Type typLDBEntry
wksta As String * 32
User As String * 32
End Type
Public Type typLDBUser
wksta As String
User As String
Connected As String
End Type
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = 1
Private Const FILE_SHARE_WRITE = 2
Private Const OPEN_EXISTING = 3
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" ( _
ByVal lpFileName As String, ByVal dwAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttr As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagAndAttr As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hHandle As Long) As Long
Private Declare Function LockFile Lib "kernel32.dll" ( _
ByVal hFile As Long, _
ByVal fileOffsetLow As Long, ByVal fileOffseyHigh As Long, _
ByVal nbBytesLow As Long, ByVal nbBytesHigh As Long) As Long
Private Declare Function UnlockFile Lib "kernel32.dll" ( _
ByVal hFile As Long, _
ByVal fileOffsetLow As Long, ByVal fileOffseyHigh As Long, _
ByVal nbBytesLow As Long, ByVal nbBytesHigh As Long) As Long
Function ReadLdb(strDB As String, ByRef arrUsrs() As typLDBUser, _
ByRef strErrMsg As String) As Long
Dim strLDB As String, f As Integer, hFile As Long
Dim rec As typLDBEntry, strWsta As String, strUsr As String
Dim usrPos As Long, usrCnt As Long, retVal As Long
Dim NbConnected As Long
' Attention : là j'ai fait simple
strLDB = Replace(strDB, ".mdb", ".ldb")
If Dir(strLDB) = "" Then
If Not IsFileUnused(strDB, strErrMsg) Then ReadLdb = &H10000
Exit Function
End If
hFile = CreateFile(strLDB, GENERIC_READ, _
FILE_SHARE_READ + FILE_SHARE_WRITE, _
0, OPEN_EXISTING, 0, 0)
f = FreeFile()
Open strLDB For Binary As #f
Do
Get #f, , rec
strWsta = Left(rec.wksta, InStr(1, rec.wksta, vbNullChar) - 1)
strUsr = Left(rec.User, InStr(1, rec.User, vbNullChar) - 1)
usrPos = usrPos + 1
If Len(strUsr) > 0 Then
usrCnt = usrCnt + 1
ReDim Preserve arrUsrs(1 To usrCnt)
arrUsrs(usrCnt).wksta = strWsta
arrUsrs(usrCnt).User = strUsr
retVal = LockFile(hFile, &H10000000 + usrPos, 0, 1, 0)
If retVal Then
retVal = UnlockFile(hFile, &H10000000 + usrPos, 0, 1, 0)
arrUsrs(usrCnt).Connected = "Non"
Else
arrUsrs(usrCnt).Connected = "Oui"
NbConnected = NbConnected + 1
End If
End If
Loop Until EOF(f)
Close f
retVal = CloseHandle(hFile)
ReadLdb = NbConnected
End Function
Function IsFileUnused(strFile, ByRef strErrMsg) As Boolean
Dim f As Integer, blnReturn As Boolean
blnReturn = True
If Dir(strFile) = "" Then
strErrMsg = "Fichier n'existe pas"
blnReturn = False
Else
f = FreeFile()
On Error Resume Next
Open strFile For Binary Access Read Shared As #f
strErrMsg = Err.Description
Close f
On Error GoTo 0
If Len(strErrMsg) > 0 Then blnReturn = False
End If
IsFileUnused = blnReturn
End Function |
.LDB ne se remet pas à jour après déconnection user
Répondre avec citation
Partager