'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'*******************************************
'muti hook mouse simplifié (molete souris sur frame)
'défilement dans controls liste frame
'author:patricktoulon
' Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************
Option Explicit
#If VBA7 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal Length As Long)
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 LongPtr, lParam As Any) 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
Public plHooking As LongPtr ' permet de savoir si le hook est activé ou pas
#Else
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal source As Long, ByVal length As Long)
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
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public plHooking As Long ' permet de savoir si le hook est activé ou pas
#End If
Type POINTAPI: X As Long: Y As Long: End Type
Type MSLLHOOKSTRUCT: pt As POINTAPI: mouseData As Long: flags As Long: time As Long: dwExtraInfo As Long: End Type
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Public udtlParamStuct As MSLLHOOKSTRUCT
Public CtrlHooked As Object ' sera associé à la ListBox
Public pos As POINTAPI
Public EpC As Variant
'**********************************
'à mettre dans la frame ou le control qui est sensé le déclencher
'ce peut être un control à l'interieur de la frame
' Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************
Sub rouletambour(obj)
'si ca n'a pas démarrer on demarre le hook
If Not CtrlHooked Is Nothing Then If CtrlHooked.Name <> obj.Name Then UnHookMouse
Call HookMouse(obj)
End Sub
'
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
#If VBA7 Then
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As Long) 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 crash en désactivant les erreurs
Dim Criter
GetCursorPos pos
Criter = pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3) 'recupère les coordonnée en pixel (left/top/right/bottom du control)
If Not Criter Then UnHookMouse 'quand on est plus dans le périmètre du control bye bye !!
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 With
End If
Exit Function
End If
LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
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 choppe le rectangle du control par raport à l'ecran(pas du parent!!!!) du control 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 Sub
' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
If Not obj Is Nothing Then
Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, K As Double, PPx, A, z
Lft = obj.Left: Ltop = obj.Top: Set P = obj.Parent ' Normalement Page, Frame ou UserForm
PPx = 0.75 'utilisez ici la méthode pour choper votre coeff point/pixel
Do
PInsWidth = P.InsideWidth: PInsHeight = P.InsideHeight ' Le Page en est pourvu, mais pas le Multipage.
If TypeOf P Is MSForms.Page Then Set P = P.Parent ' Prend le Multipage, car le Page est sans positionnement.
K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.Left + K): Ltop = (Ltop + P.Top + P.Height - K - PInsHeight)
If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
Set P = P.Parent
Loop
EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height) / PPx)
End If
End Function
