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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
| Public Type T_AccessUser
UserId As Byte ' de 1 à 255
CommitByte As Integer 'Valeur du mot de commit dans la base Access
ComputerName As String
SecurityName As String
isLogOn As Boolean 'Vrai si utilisateur encore connecté
'Ces autres renseignements sont propres à mon application
DatConnect As Date 'date de création des fichiers tmp
Version As String 'Dernière version du logiciel utilisé
UserName As String 'Nom de connexion de l'utilisateur du logiciel
ComputerBase As String 'Nom de l'ordinateur ayant la base de production (si connu)
End Type
Public Type T_AccessConnexions
Nbr As Long
CommitByte(256) As Integer
User() As T_AccessUser
End Type
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 Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Long) As Long
Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" (ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) _
As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Private Const LOCKFILE_FAIL_IMMEDIATELY = &H1
Private Const LOCKFILE_EXCLUSIVE_LOCK = &H2
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_BEGIN = 0
Private Const FILE_END = 2
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Public Const OF_SHARE_EXCLUSIVE = &H10
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const OPEN_EXISTING = 3
Private Const OPEN_ALWAYS = 4
Private Const OPENCHANNEL = 4110
'---------------------------------------------------------------
' Lecture de toutes les informations disponibles dans les
' fichier mdb et ldb pour remplir la structure Config.Connexions
'---------------------------------------------------------------
Public Sub LireConnexions(BaseName As String, ByRef Connexions As T_AccessConnexions)
Dim LdbName As String
Dim hFile As Long
Dim dwPos As Long
Dim res As Long
Dim i As Long
Dim nbrConnect As Long
Dim iFicIn As Integer
'Création du nom du ldb
'(en espèrant que le BaseName est du type ~.XYZ)
LdbName = Left$(BaseName, Len(BaseName) - 3) & "ldb"
Connexions.Nbr = 0
ReDim Connexions.User(0)
'Tente de lire les commitBytes du mdb :
iFicIn = FreeFile
If Dir$(BaseName) <> vbNullString Then
Open BaseName For Binary Access Read As #iFicIn
Get #iFicIn, &H600, Connexions.CommitByte
Close #iFicIn
'Tente d'ouvrir le ldb
hFile = CreateFile(LdbName, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
If hFile <> INVALID_HANDLE_VALUE Then
dwPos = SetFilePointer(hFile, 0, 0, FILE_END)
For i = 1 To 255
dwPos = &H10000000 + i
res = LockFile(hFile, dwPos, 0, 1, 0)
'Si impossible à locker, c'est que la connexion existe déjà !
If res = 0 Then
Connexions.Nbr = Connexions.Nbr + 1
ReDim Preserve Connexions.User(Connexions.Nbr)
With Connexions.User(Connexions.Nbr)
SeekAbsolute hFile, 0, 64 * i - 64
.UserId = i
.ComputerName = ReadBytes(hFile, 32)
.SecurityName = ReadBytes(hFile, 32)
.CommitByte = Connexions.CommitByte(i)
'Les données suivantes sont fournies par défaut
.isLogOn = True
.DatConnect = Now 'Par défaut !
.UserName = Config.User.UserName
.Version = Config.User.Version
.ComputerBase = RetrouveComputerBase()
If UCase$(.ComputerBase) = "C:" Then
.ComputerBase = .ComputerName
End If
End With
Else
res = UnlockFile(hFile, dwPos, 0, 1, 0)
End If
Next
'Refermer ce fichier
Call CloseHandle(hFile)
End If
End If
End Sub
'--------------------------------------------------------------------------
' Retourne le nombre d'utilisateurs connectés actuellement à la base
'--------------------------------------------------------------------------
Private Function GetNombreConnexions(BaseName As String) As Long
Dim C As T_AccessConnexions
'lecture utilisateurs actuellement connectés à la base
On Error Resume Next
If Dir$(BaseName) <> vbNullString Then
C.Nbr = 0
Call LireConnexions(BaseName, C)
GetNombreConnexions = C.Nbr
End If
Err.Clear
End Function |
