'*****************************************************************************************************
'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'*******************************************
'hook mouse simplifié (mollete souris)
'
'Author:patricktoulon
'-------------------------------------
'Exemple d'appel dans userform
'L'object appelant peut être un control dans le control à scroller
'
'Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'------------------------------------
'code indenté avec Vba Indenter 3.1
'**********************************
Option Explicit
Type POINTAPI
X As Long
Y As Long
End Type
#If Win64 Then
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As LongPtr
End Type
#Else
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
#End If
#If Win64 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As Long, lParam As LongPtr) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Public udtlParamStuct As MSLLHOOKSTRUCT
#If Win64 Then
Public plHooking As LongPtr ' To know if the hook is active or not
#Else
Public plHooking As Long ' To know if the hook is active or not
#End If
Public CtrlHooked As Object ' Will be associated with the ListBox
Public pos As POINTAPI
Public EpC As Variant
Public PosY As Long
Sub rouletambour(obj)
' Start the hook if it hasn't started yet
If Not CtrlHooked Is Nothing Then
If CtrlHooked.Name <> obj.Name Then UnHookMouse
End If
Call HookMouse(obj)
End Sub
Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
#If Win64 Then
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
#Else
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
On Error GoTo ErrorCritique ' Improved error handling
Dim Criter As Boolean, i&, Mdata
GetCursorPos pos
Criter = plHooking <> 0 'si le thread plhooking <>0 c'est bon
Criter = Criter And IsArray(EpC) 'si EpC est un array c'est bon
Criter = Criter And Not CtrlHooked Is Nothing 'si CtrlHooked n'est pas nothing c'est bon
Criter = Criter And wParam <> 0 'si wparam <>0alors la struture de la mouse a été captée
'et en fin si les coordonnées sont dans le rectangle corespondant au corordonnées du rectangle du control c'est bon
Criter = Criter And pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3) ' Get control's coordinates in pixels
If Not Criter Then UnHookMouse: Exit Function 'possibilité non critique criter est false alors on sort(le move sur control refera un nouvel appel)
If (nCode = HC_ACTION) Then 'si ncode renvoie bien action alors on est bon la structure est captée
If wParam = WM_MOUSEWHEEL Then 'si wparam renvoie bien 522 soit &H20A alors la structure est bonne
LowLevelMouseProc = True 'alors on est true(32 bits relance le hook en looping (pas le 64)
Mdata = GetHookStruct(lParam).mouseData 'on récupère le mouse data
With CtrlHooked
CtrlHooked.SetFocus
'selon le control appellant (ou designé)
'on testera le typeof et le typename selon les configs typeof renvoie une mauvaise reponse
Select Case True
Case TypeOf CtrlHooked Is Frame Or TypeName(CtrlHooked) = Frame
If Mdata > 0 Then .ScrollTop = .ScrollTop - 45 Else .ScrollTop = .ScrollTop + 45
Case TypeOf CtrlHooked Is ListBox Or TypeName(CtrlHooked) = "ListBox"
If Mdata > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
Case TypeOf CtrlHooked Is ComboBox Or TypeName(CtrlHooked) = "ComboBox"
If Mdata > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
Case TypeOf CtrlHooked Is TextBox Or TypeName(CtrlHooked) = "TextBox"
If Mdata > 0 Then
CtrlHooked.CurLine = Application.Max(0, CtrlHooked.CurLine - 2)
Else
CtrlHooked.CurLine = Application.Min(CtrlHooked.LineCount - 1, CtrlHooked.CurLine + 2)
End If
Case TypeOf CtrlHooked Is ScrollBar Or TypeName(CtrlHooked) = "ScrollBar"
If Mdata > 0 Then .Value = .Value - 1 Else .Value = .Value + 1
End Select
End With
End If
Exit Function 'ici on sort tout c'est bien passé
End If
'----------------------------------'
'Gestion d'erreur critique dans un switch entre deux exit function
Nettoyage: 'ici on a été renvoyé par errorCritique
If Err.Number <> 0 Then Err.Clear: UnHookMouse
On Error GoTo 0
LowLevelMouseProc = CallNextHookEx(plHooking, nCode, wParam, lParam) 'évidemment là on est obligé de rappeller car tout est mort ,dead ,ralbate ,crevé etc...
Exit Function ' on sort on va pas boucler sur une erreur ca suffit une fois espece de saucisse!!!!
ErrorCritique:
MsgBox "Une erreur est survenue pendant hook " & vbCrLf & Err.Description, vbCritical
Resume Nettoyage ' on renvoie au nettoyage pour tout nettoyer et relancer avec callnexthook neccessaire cette fois ci car externe à la partie ou tout se passe bien
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
If plHooking < 1 Then ' active le hook si un autre n'est pas démarré
EpC = EmplacementControl(ControlToScroll) ' Get the control's rectangle relative to the screen (not the parent) into an array
Set CtrlHooked = ControlToScroll
plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
End If
End Sub
Public Sub UnHookMouse()
' Déactive le hook si un thread(plHooking) a été précédemment démarré
If plHooking <> 0 Then
UnhookWindowsHookEx (plHooking)
plHooking = 0
Set CtrlHooked = Nothing
End If
PosY = 0
End Sub
' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
If Not obj Is Nothing Then
Dim Lft As Double, Ltop As Double, plus, ParentX As Object, ParentXInsWidth As Double, ParentXInsHeight As Double, K As Double, PPx, A, z
With CreateObject("WScript.Shell")
PPx = 1 / (.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72)
End With
If Not TypeOf obj.Parent Is Worksheet And Not TypeName(obj) = "WorkSheet" Then
If PosY > obj.Height Then plus = (obj.Font.Size / 0.75 - 1) * obj.ListRows Else plus = 0
Lft = obj.Left
Ltop = obj.Top ' Normalement Page, Frame ou UserForm
Set ParentX = obj.Parent
Do
ParentXInsWidth = ParentX.InsideWidth ' Le Page en est pourvu, mais pas le Multipage
ParentXInsHeight = ParentX.InsideHeight
If TypeOf ParentX Is MSForms.Page Then Set ParentX = ParentX.Parent ' Prend le Multipage, car le Page est sans positionnement
K = (ParentX.Width - ParentXInsWidth) / 2
Lft = (Lft + ParentX.Left + K)
Ltop = (Ltop + ParentX.Top + ParentX.Height - K - ParentXInsHeight)
If Not (TypeOf ParentX Is MSForms.Frame Or TypeOf ParentX Is MSForms.MultiPage) Then Exit Do
Set ParentX = ParentX.Parent
Loop
EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height + plus) / PPx)
End If
Else
'plus tard !!! pour les oleobject oleobject in worksheet(voir tuto patricktoulon pointoscreenpixel)
'Debug.Print Join(EmplacementControl, "-----")
End If
End Function