Mouse Wheel Hook (faire défiler le contenu d'une combobox/listbox avec la roulette)

[patricktoulon]

sauve le sous un autre nom
et enlève ce qui n'est pas nécessaire

 

[GClaire]

Hello

Voici.

Mais c'est quand même, bizard, car tout fonctionné avant, cette ré installation Win10 64 et pack office 365.

Merci

 

[patricktoulon]

oui mais avant tu avais quoi comme exploitation?
un essai
change le code en entier

'*******************************************
'multi hook simplifié (molete souris sur activx)
'défilement dans controls liste frame
'patricktoulon
'**********************************
Option Explicit
#If VBA7 Then
    'Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
     Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)

    'Private 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
     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 LongPrt

    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
  
#Else
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    Private Declare PtrSafe 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 PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

#End If

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 udtlParamStuct As MSLLHOOKSTRUCT
Public plHooking As Long    ' permet de savoir si le hook est activé ou pas
Public CtrlHooked As Object    ' sera associé à la ListBox

'
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
    On Error Resume Next    'en cas de mouvement très rapide,'évitons les crash en désactivant les erreurs
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                Select Case TypeName(CtrlHooked)    ' déplace l'ascenseur en fonction de la molette ' l'info est stockée dans lParam
                Case "ListBox", "ComboBox": If GetHookStruct(lParam).mouseData > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
                Case "Frame": If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 2 Else .ScrollTop = .ScrollTop + 2
                End Select
            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é
        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

 

[GClaire]

Patrick

Merci pour la réponse.

J'avais le même car une License en ligne win10 64

Idem pour office 365

Pour cekla que je ne comprends pas.

J'imaginais des complements ou autre a integré dans excel, mais je ne vois pas lesquels, si besoin il y avait.

La j'ai tésté, j'ai une erreur ici

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 LongPrt

Type defini par l'utilisateur non défini.

Merci

 

[patricktoulon]

ben alors tes librairies sont en vrac
l’installation a du mal se passer
te reste plus qu'a tout refaire office et peut être même Windows
tu n'a pas le choix

 

[GClaire]

Hello

Aille je viens de voir que mon message n'a pas était posté, j'étais sur mon tel, désolé.

Merrci pour ta réponse, qui ne me réconforte pas, lol.

Donc, j'ai tenté une réparation du pack office, toujours pareil.

Je peux tenter une réinstallation du pack office (Je pense qu'il doit y avoir une procédure pour désinstaller proprement celui-ci et puis surtout sauvegarder mes fichiers outlook

Par contre pour moi trés compliqué de réinstaller Windows 10, car de nombreux soft et des paramètres de ceux ci, je vais y passer un temps de dingue.

Merci.

G'Claire

 

[GClaire]

Re

Bon, j'ai tenté une réinstalle d'office, mais cela n'a rien changé.

Alors de ce fait, j'ai voulu tester sur deux autres PC, est pareil, cela ne fonctionne pas.

1 équipé de win10 et pack office 365
1 équipé de win 11 et pack office 365

C'est une License familiale de 5 postes

Bizard quand même car il fonctionné très bien avant sur mon poste tout au moins, jamais testés sur les deux autres.

Es-ce qu'il y'a des fonctionnalités a mettre dans les compléments / Gestionnaire de compléments ou dans outils / Références?

Sinon tant pis, je devrait me résoudre a supprimer cette option que je trouvais super bien.

Merci beaucoup.

G'Claire

 

[patricktoulon]

Bonsoir
ma fois perso je sais pas j’exècre W10 je ne pourrais pas t'aider de ce coté là
W11 pas encore testé mais a mon avis il n'aura pas chez moi une meilleure note

 

[GClaire]

Patrick

Merci.

Tu as testé le fichier que j'ai mis en ligne?

Et je ne retrouve pas le post, de cette procédure pour voir si quelque chose avait était indiqué.

 

[patricktoulon]

re
oui chez moi ca fonctionnait
normal je suis sur excel 2013 32 bits c'est les déclarations des api du #else qui prennent en charge le hooking
moi je n'ai pas de probleme avec mon module

 

[GClaire]

Hello patrick

Merci

Je viens de relire certains post justement qui en parle de la gestion avec win 64 bits et excel 64 bits, car j'ai bien un 64 Bits

J'essaye d'adapter avec le code de BrunoM45

Merci

 

[nano33320]

Bonjour à tous,

Suite à la demande de Fmiste concernant la possibilité de faire défiler le contenu d'une ComboBox

Je me suis aperçu qu'il n'y avait pas tellement de fil traitant ce sujet sur le forum
ou du moins je n'en ai pas trouvé concernant le terme "Mouse wheel"

Je mets donc ici à disposition, le classeur avec le code qui va bien

Cela pourra toujours servir à quelqu'un

Au plaisir

Merci beaucoup pour le job
Liste beaucoup plus ergonomique à l'usage
Nano

 

[Dudu2]

Bonjour,
Je ne sais pas de quoi il s'agit au juste, mais ce fil date un peu.
Pour le Scroll souris, voir plutôt cette ressource qui est plus récente.

VBA - Vertical Scroll en ComboBox, ListBox et TextBox (ActiveX en Feuille et en UserForm)

Le fichier à télécharger contient: Le Module_ScrollListComboTextBoxes à importer dans le projet VBA. Un UserForms de test contenant des ComboBoxes, des ListBoxes et des TextBoxes. Une feuille de test contenant une ComboBox, une ListBox et une...

excel-downloads.com