Combobox - Scroller avec la souris
Bonjour à tous,
J’essaye de créer une petite application pour gérer un budget personnel, qui corresponde à mes besoins.
Pour enregistrer mes éléments de budget (à partir de mes relevés bancaires), j’ai créé un formulaire (UserForm) de saisie qui comporte : le mois saisi, les opérations, et le mode d’opération (CB, chèque, etc.). Plutôt que de devoir cliquer avec la souris sur les flèches haut/bas de la barre de défilement je souhaiterais pouvoir scroller avec la souris.
J’ai trouvé, sur Internet, des codes qui sont sensés me permettre d’arriver à mes fins. Malheusement, çà ne fonctionne pas et mes connaissances en VBA Excel sont insuffisantes et je n’arrive pas à les adapter à mes besoins.
A toutes fins utiles, je joins deux fichiers : « Budget_test_1 » qui fonctionne sans code ajouté concernant le « Scroll Souris » et « Budget_test_2 » dans lequel j’ai intégrés les codes trouvés sur Internet (et que je n’arrive pas à faire fonctionner).
Pour infos, je travaille avec Microsoft Office Professionnal Plus 2021 64 bits.
Si quelqu'un pouvait m'aider concernant les codes nécessaires à l'exécution de ces taches, ce serait vraiment sympa.
D’avance merci !!!!
Bonsoir,
votre fichier en retour avec l'intégration d'un module de scroll molette : modHooKWheelMouse
et son intégration sur les trois ComboBox du USF.
Le fichier :
@ bientôt
LouReeD
Bonjour LouReeD,
Merci de vous être interessé à mon problème.
J'ai testé le fichier que vous m'avez envoyé en retour et j'ai un méssage d'erreur lorsque je tente d'utiliser l'UserForm de saisie.
A la ligne ; '" 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) du module "modHooKWheelMouse", "AddressOf LowLevelMouseProc" se met en surlignage et le message suivant s'affiche "Erreur de compilation / Incompatibilité de type".
Je vais chercher sur Internet s'il est possible d'empêcher ce message d'erreur et comment le corriger.
Si vous avez des idées à ce sujet, je suis preneur bien sûr.
Merci encore
Cordialement
Bramoset30
ReBonjour,
Voici un code à positionner dans ModHookWheelMouse, que j'ai trouvé sur Internet à force de chercher, et qui sembre fonctionner ;
'------------------------------------------------------------------------------------------------------------
' Module : modHookWheelMouse
' Date : 27/05/2012
' But : Permet d'utiliser la molette de la souris avec ComboBox ou ListBox dans une feuille ou UserForm
'------------------------------------------------------------------------------------------------------------
Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookEx Lib "User32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "User32" (ByVal hHook As LongPtr, ByVal nCode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "User32" (ByVal hHook As LongPtr) As LongPtr
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 LongPtr
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
'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 LongPtr
Dim hWnd_App As LongPtr
Dim hWnd_Desk As LongPtr
Dim hWnd_Sheet As LongPtr
Dim hWnd_UserForm As LongPtr
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)
Debug.Print Timer, "Hook ON"
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
Debug.Print Timer, "Hook OFF"
End If
End Sub
A suivre
Merci encore LouReeD pour votre participation
Cordialement
Bramoset30
Bonsoir,
merci pour ce retour.
@ bientôt
LouReeD