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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
| Option Explicit
'*********************** Module permettant de récupérer la rotation de la roulette souris et ******************
'*********************** de créer des événements suivant la position du curseur de la souris *****************
'--- prés requis ---------------------------------------------------------------------------------------------
'---------- le composant pour lequel on veux créer l'événement et/ou récupérer la rotation roulette ----------
'---------------------- doit impérativement avoir la propriété Hwnd ------------------------------------------
'-------------------------------------------------------------------------------------------------------------
'/////////////////////// Partie événements souris \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Private Type POINTAPI
X As Long
Y As Long
End Type
'Récupère la position du curseur, en coordonnées d'écran.
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Récupère le handle de la fenêtre qui contient le point spécifié.
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'Récupère le handle de la fenêtre parent de la fenêtre enfant spécifié.
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Dim Pxy As POINTAPI
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Récupère les dimensions du rectangle de la fenêtre spécifiée.
'Les dimensions sont indiquées en coordonnées d'écran qui sont relatives au coin supérieur gauche de l'écran.
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
'Pour lire les touches du clavier
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
'Pour surveiller le curseur de la souris
'Crée une minuterie avec la valeur de délai d'attente spécifié.
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
'Détruit la minuterie spécifiée.
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
'variables pour gérer les évènements et paramètres.
Dim OldCtrlActiver As String, CtrlActiver As String, CtrlAsurveiller As Boolean
Dim MemoBtPresser As Integer, MemoShift As Integer
'/////////////////////// Partie événements roulette de la souris \\\\\\\\\\\\\\\\\\\\\\\\\\
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" ( _
ByVal hWnd As Long, _
ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _
ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _
ByVal hWnd As Long, _
ByVal lpString As String) As Long
Private Declare Function GetSystemMetrics Lib "user32" ( _
ByVal nIndex As Long) As Long
Private Const SM_MOUSEWHEELPRESENT = 75
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
Private Const GWL_WNDPROC = (-4)
Dim RoueCentrale As Boolean
Private Sub Main()
'prend la valeur True si La souris reliée à l'ordinateur a une roulette
RoueCentrale = CBool(GetSystemMetrics(SM_MOUSEWHEELPRESENT))
Form1.Show
End Sub
'/////////////////////// Partie événements roulette de la souris \\\\\\\\\\\\\\\\\\\\\\\\\\
Private Function HiWord(dw As Long) As Integer
If dw And &H80000000 Then HiWord = (dw \ 65535) - 1 Else HiWord = dw \ 65535
End Function
Private Function SurveillanceRoulette(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'cette fonction n'est enclenchée que si la partie "SurveillanceMouse" est sur un contrôle a traiter et sera arrêté par le même procès
Dim TheCtrl As Control, Result As Integer
Set TheCtrl = Screen.ActiveControl
If uMsg = WM_MOUSEWHEEL Then ' la roulette a été utilisée
Result = HiWord(wParam) / WHEEL_DELTA '-1 ou 1
Select Case TypeName(TheCtrl)
Case "MSFlexGrid", "MSHFlexGrid"
'MemoBtPresser = vbRightButton = agir sur le défilement des colonnes
If Result < 0 Then '-1
If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
TheCtrl.LeftCol = TheCtrl.LeftCol + 1
Else 'agir sur le défilement des lignes
TheCtrl.TopRow = TheCtrl.TopRow + 1
End If
Else '1
If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
If TheCtrl.LeftCol > TheCtrl.FixedCols Then TheCtrl.LeftCol = TheCtrl.LeftCol - 1
Else 'agir sur le défilement des lignes
If TheCtrl.TopRow > TheCtrl.FixedRows Then TheCtrl.TopRow = TheCtrl.TopRow - 1
End If
End If
Case "DataGrid"
If Result < 0 Then
If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
TheCtrl.Scroll 1, 0
Else 'agir sur le défilement des lignes
TheCtrl.Scroll 0, 1
End If
Else
If MemoBtPresser = vbRightButton Then 'agir sur le défilement des colonnes
TheCtrl.Scroll -1, 0
Else 'agir sur le défilement des lignes
TheCtrl.Scroll 0, -1
End If
End If
End Select
'Passez le message au procédé de fenêtre de défaut et puis sur le parent
DefWindowProc hWnd, uMsg, wParam, lParam
Else
'Message manipulé, n'appelle pas le procédé original de fenêtre
SurveillanceRoulette = CallWindowProc(GetProp(TheCtrl.hWnd, "PrevWndProc"), hWnd, uMsg, wParam, lParam)
End If
Set TheCtrl = Nothing
End Function
Private Sub DemarerSurveillanceRoulette(Controle As Control)
'Crée/enclenche, en tache de fond, la surveillance de la de la roulette souris, enclenché par "SurveillanceMouse"
SetProp Controle.hWnd, "PrevWndProc", SetWindowLong(Controle.hWnd, GWL_WNDPROC, AddressOf SurveillanceRoulette)
End Sub
Private Sub FinSurveillanceRoulette(Controle As Control)
'pour mettre fin proprement à la routine utilisation de la roulette souris, enclenché par "SurveillanceMouse"
SetWindowLong Controle.hWnd, GWL_WNDPROC, GetProp(Controle.hWnd, "PrevWndProc")
RemoveProp Controle.hWnd, "PrevWndProc"
End Sub
'/////////////////////// Partie événements souris \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Public Sub SurveillanceMouse()
Dim HwndLut As Long
'surveillance du déplacement du curseur de la souris
GetCursorPos Pxy 'Obtention de la position actuelle de la souris
HwndLut = WindowFromPoint(Pxy.X, Pxy.Y) 'Obtention de la fenêtre sous la souris
If Identification(HwndLut) = False Then
'recherche du Hwnd parent par apport au Hwnd sous le curseur de la souris (exemple cas du ComboBox)
If GetParent(HwndLut) <> 0 Then Identification GetParent(HwndLut)
'Else
'Identification(HwndLut) = True
'un contrôle que l'on veut surveiller à été trouvé sous la souris
End If
'analyse suite au résultat de la recherche du composant sous le curseur de la souris
If CtrlAsurveiller = True Then
If CtrlActiver <> OldCtrlActiver Then
'la souris vient de quitté un contrôle qui était surveillé
LancerEventCtrl OldCtrlActiver, "Quitte"
'la souris commence a passer au dessus du nouveau contrôle devant être surveillé
LancerEventCtrl CtrlActiver, "Entre"
OldCtrlActiver = CtrlActiver
End If
End If
If CtrlAsurveiller = False Then
If CtrlActiver <> "" Then 'la souris quitte le contrôle qui était surveillé
LancerEventCtrl CtrlActiver, "Quitte"
CtrlActiver = "": OldCtrlActiver = ""
MemoBtPresser = 0: MemoShift = 0
End If
End If
DoEvents
End Sub
Private Function Identification(HwndSoumis As Long) As Boolean
Dim Lobjet As Control
'parcour de tous les contrôles du Form
For Each Lobjet In Screen.ActiveForm.Controls
Select Case TypeName(Lobjet)
'Sélection d'un composant qui n'a pas les évènements souris n'y l'évènements roulette et/ou
'un composant qui n'a pas l'évènement entrée/sortie sur la surface du contrôle
Case "MSFlexGrid", "MSHFlexGrid", "DataGrid"
If Lobjet.hWnd = HwndSoumis Then
Identification = True
CtrlActiver = Lobjet.Name
RecupeParametres Lobjet
Exit For
End If
End Select
Next
CtrlAsurveiller = Identification
End Function
Private Sub RecupeParametres(QuelCtrl As Control)
'procédure pour récupération des informations a passer aux procédures Ctrl_MouseDown, Ctrl_MouseMove et Ctrl_MouseUp
'MemoBtPresser et MemoShift peuvent aussi servir pour la procédure "SurveillanceRoulette"
'--- Lecture des états et positionnement du curseur souris ---
Dim XButton As Integer
'détection d'un ou plusieurs boutons en appuis
If GetAsyncKeyState(vbLeftButton) <> 0 Then XButton = vbLeftButton
If GetAsyncKeyState(vbRightButton) <> 0 Then XButton = XButton + vbRightButton
If GetAsyncKeyState(vbMiddleButton) <> 0 Then XButton = XButton + vbMiddleButton
'Shift = MAJ, CTRL et ALT
Dim XShift As Integer
'détection d'une ou plusieurs touches du clavier en appuis
If GetAsyncKeyState(vbKeyShift) <> 0 Then XShift = vbShiftMask
If GetAsyncKeyState(vbKeyControl) <> 0 Then XShift = XShift + vbCtrlMask
If GetAsyncKeyState(vbKeyMenu) <> 0 Then XShift = XShift + vbAltMask
Dim Rectangle As RECT, PosX As Long, PosY As Long
'récupération des cordonnées du curseur souris en référence du coin haut à gauche du contrôle
GetWindowRect QuelCtrl.hWnd, Rectangle
PosX = Pxy.X - Rectangle.Left: PosY = Pxy.Y - Rectangle.Top
'--- Enclenchement de la procédure évènement appropriée ---
If CtrlActiver = OldCtrlActiver Then
If XButton > MemoBtPresser And XButton <> 0 Then
Ctrl_MouseDown QuelCtrl, XButton, XShift, PosX, PosY
End If
If XButton = MemoBtPresser Then
Ctrl_MouseMove QuelCtrl, XButton, XShift, PosX, PosY
End If
If XButton < MemoBtPresser Then
Ctrl_MouseUp QuelCtrl, XButton, XShift, PosX, PosY
End If
End If
MemoBtPresser = XButton: MemoShift = XShift
End Sub
Private Sub LancerEventCtrl(NomDuCtrl As String, procédureAlancer As String)
'parcour de tous les contrôles du Form pour pouvoir enclancher les procedures Entrée ou Sortie de la surface du composont
Dim Lobjet As Control
For Each Lobjet In Screen.ActiveForm.Controls
If Lobjet.Name = NomDuCtrl Then
If procédureAlancer = "Entre" Then Ctrl_MouseEntrer Lobjet Else Ctrl_MouseSortie Lobjet
Exit For
End If
Next
End Sub
'---------------------------- Les 5 procédures d'évènements souris pour les contrôles n'en ayant pas ---------------------------
Private Sub Ctrl_MouseEntrer(QuelCtrl As Control)
'le curseur de la souris entre sur la surface du contrôle (ne se produit qu'une seule fois)
Select Case QuelCtrl.Name
Case "MSFlexGrid1", "MSHFlexGrid1", "DataGrid1"
'pour chacun de ces composants je désire faire bouger les cellules avec la roulette de la souris
QuelCtrl.SetFocus
If RoueCentrale Then DemarerSurveillanceRoulette QuelCtrl 'activation de la surveillance de la roulette
'pour le DataGrid il faut sortir de l'édition de la cellule
If QuelCtrl.Name = "DataGrid1" Then QuelCtrl.EditActive = False
' Case "autre nom d'un composant"
' Case "autre ....."
End Select
End Sub
Private Sub Ctrl_MouseDown(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
'X et Y sont dans l'unité Pixels, c'est voulu pour être utilisé par les APIs
'Select Case QuelCtrl.Name
' Case "Nom du composant"
' Case "autre nom d'un composant"
' Case "autre ....."
'End Select
End Sub
Private Sub Ctrl_MouseMove(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
'Select Case QuelCtrl.Name
' Case "Nom du composant"
' Case "autre nom d'un composant"
' Case "autre ....."
'End Select
End Sub
Private Sub Ctrl_MouseUp(QuelCtrl As Control, Button As Integer, Shift As Integer, X As Long, Y As Long)
'Select Case QuelCtrl.Name
' Case "Nom du composant"
' Case "autre nom d'un composant"
' Case "autre ....."
'End Select
End Sub
Private Sub Ctrl_MouseSortie(QuelCtrl As Control)
'le curseur de la souris vient de sortir de la surface du contrôle (ne se produit qu'une seule fois)
Select Case QuelCtrl.Name
Case "MSFlexGrid1", "MSHFlexGrid1", "DataGrid1"
If RoueCentrale Then FinSurveillanceRoulette QuelCtrl
' Case "autre nom d'un composant"
' Case "autre ....."
End Select
End Sub |
