'------------------------------------------------------------------------------------------------------------
' Source : Philippe734 http://www.vbfrance.com//code.aspx?ID=54334
' Module : modHookWheelMouse
' Date : 27/05/2012
' But : Permet d'utiliser la molette de la souris avec ComboBox ou ListBox dans une feuille ou UserForm
'
' Prise en charge de la molette de la souris pour ComboBox et ListBox d'une feuille excel ou d'une UserForm.
' Un fichier à ajouter dans vos documents excel pour utiliser la molette. On peut trouver facilement un code
' source pour utiliser la molette de la souris avec ComboBox ou ListeBox dans une UserForm. Mais j'ai eu des
' difficultés pour trouver un code source afin d'utiliser la molette avec ces objets insérés dans une feuille
' excel. Donc, rien d'extraordinaire, la méthode est basée sur un hook classic. Sauf que le handle hooké a
' justement été l'élément que j'ai galéré à identifier afin que ces deux objets puissent utiliser la molette.
' Le code du module n'est pas de moi. Je l'ai un peu modifié pour le rendre facilement réutilisable.
'------------------------------------------------------------------------------------------------------------
Option Explicit
Private Declare Function FindWindow& Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String)
Private Declare Function FindWindowEx& Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String)
Private Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, ByVal nIndex As Long)
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)
Private Declare Function CallNextHookEx& Lib "user32" ( _
ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any)
Private Declare Function UnhookWindowsHookEx& Lib "user32" ( _
ByVal hHook As Long)
Public Enum OWNER
eSHEET = 1
eUSERFORM = 2
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
Private udtlParamStuct As MSLLHOOKSTRUCT
' permet de savoir si le hook est activé ou pas
Public plHooking As Long
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'en cas de mouvement très rapide,
'évitons les crash en désactivant les erreurs
On Error Resume Next
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
LowLevelMouseProc = True
With CtrlHooked
' déplace l'ascenseur en fonction de la molette
' l'info est stockée dans lParam
If GetHookStruct(lParam).mouseData > 0 Then
.TopIndex = .TopIndex - 3
Else
.TopIndex = .TopIndex + 3
End If
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, ByVal SheetOrForm As OWNER, Optional ByVal FormName As String)
Dim hWnd As Long
Dim hWnd_App As Long
Dim hWnd_Desk As Long
Dim hWnd_Sheet As Long
Dim hWnd_UserForm As Long
Const VBA_EXCEL_CLASSNAME = "XLMAIN"
Const VBA_EXCELSHEET_CLASSNAME = "EXCEL7"
Const VBA_EXCELWORKBOOK_CLASSNAME = "XLDESK"
Const VBA_USERFORM_CLASSNAME = "ThunderDFrame"
'---
' active le hook s'il n'avait pas déjà été activé
If plHooking < 1 Then
' retourne l'handle d'excel
hWnd_App = FindWindow(VBA_EXCEL_CLASSNAME, vbNullString)
Select Case SheetOrForm
Case eSHEET
'trouve son fils
hWnd_Desk = FindWindowEx(hWnd_App, 0&, VBA_EXCELWORKBOOK_CLASSNAME, vbNullString)
'trouve celui de la feuille
hWnd_Sheet = FindWindowEx(hWnd_Desk, 0&, VBA_EXCELSHEET_CLASSNAME, vbNullString)
hWnd = hWnd_Sheet
Case eUSERFORM
'trouve la UserForm
hWnd_UserForm = FindWindowEx(hWnd_App, 0&, VBA_USERFORM_CLASSNAME, FormName)
If hWnd_UserForm = 0 Then
hWnd_UserForm = FindWindow(VBA_USERFORM_CLASSNAME, FormName)
End If
hWnd = hWnd_UserForm
End Select
Set CtrlHooked = ControlToScroll
' il n'y a pas de hInstance d'application, alors on utilise GetWindowLong pour obtenir l'hInstance
plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(hWnd, GWL_HINSTANCE), 0)
End If
End Sub
Public Sub UnHookMouse(Optional dummy As Byte)
' désactive le hook s'il existe
If plHooking <> 0 Then
UnhookWindowsHookEx plHooking
plHooking = 0
Set CtrlHooked = Nothing
End If
End Sub
