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 |
Partager