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 ' permet de savoir si le hook est activé ou pas
#Else
Public plHooking As Long ' permet de savoir si le hook est activé ou pas
#End If
Public CtrlHooked As Object ' sera associé à la ListBox
Public pos As POINTAPI
Public EpC As Variant
Sub rouletambour(obj)
' si ça n'a pas démarré, on démarre le hook
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 Resume Next ' en cas de mouvement très rapide, évitons les crashs en désactivant les erreurs
Dim Criter As Boolean, i&
GetCursorPos pos
Criter = pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3) ' récupère les coordonnées en pixels (left/top/right/bottom du control)
If Not Criter Then
UnHookMouse
Exit Function
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
LowLevelMouseProc = True
With CtrlHooked
If GetHookStruct(lParam).mouseData > 0 Then
.ScrollTop = .ScrollTop - 45
Else
.ScrollTop = .ScrollTop + 45
End If
End With
End If
Exit Function
End If
On Error GoTo 0
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
If plHooking < 1 Then ' active le hook s'il n'avait pas déjà été activé
EpC = EmplacementControl(ControlToScroll) ' on récupère le rectangle du contrôle par rapport à l'écran (pas du parent) du contrôle dans un array
Set CtrlHooked = ControlToScroll
plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
End If
End Sub
Public Sub UnHookMouse()
' désactive le hook s'il existe
If plHooking <> 0 Then
UnhookWindowsHookEx plHooking
plHooking = 0
Set CtrlHooked = Nothing
End If
End Sub
' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
If Not obj Is Nothing Then
Dim Lft As Double, Ltop As Double, ParentX As Object, ParentXInsWidth As Double, ParentXInsHeight As Double, K As Double, PPx, A, z
Lft = obj.Left
Ltop = obj.Top ' Normalement Page, Frame ou UserForm
Set ParentX = obj.Parent
With CreateObject("WScript.Shell")
PPx = 1 / (.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72)
End With
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) / PPx)
End If
End Function
