Pc Win 7 64 bit: Scolling sur combobox Usf

Le 21/03/2017 à 14:30

Bonjour

Je précise tout d' abord que ce que je cherche à faire doit fonctionner sur 64 bit ( ne sera jamais utilisée sur un architecture 32 bit )

Je possédè un ficher excel ou l' utilisateur doit remplir un userform pour y sauvegarder des données.

Cette Userform possédè 3 combobox qui chacune contient une centaines d' items ( des references produits entre autre )

Le scrolling par l' intermédiaire de la roulette situé sur la souris , en se positionnant dessus , serait dans ce cas d' une grande utilité.

J' ai évidemment déjà essaye de multitudes de codes trainant sur le web , mais jamais en phase avec ce que je cherche ( code pour du 32 bit , pas pour un combobox , pas pour un userfom mais directement dans une feuille Excel , etc ... )

Pourriez vous me proposer un code , même trouvée ailleurs , que je peux adapter relativement facilement et qui surtout , répond a ma demande ?

Je vous remercie d'avance pour vos réponses.

Cordialement

Le 21/03/2017 à 15:57

Bonsoir,

A tout hasard... Essaie la pièce jointe !

A+

128scrollcombo64.xlsm (857.26 Ko)
Le 21/03/2017 à 17:11

Bonjour

Merci de votre réponse et de votre proposition :

Cependant un problème se pose sur un morceau du code , lors de l' exécution de votre fichier sur mon pc (Excel 2016 et Win 7 Pro 64 bit )

Merci

Édit a 17 h 44 :

Problème résolu en partie j' ai réussi a faire marcher VOTRE ficher correctement sur mon PC ! Il manquait un PtrSafe a un endroit.

Le voici une fois corrigée de mon coté :

139scrollcombo64.xlsm (834.50 Ko)

Un autre problème se pose en ce qui concerne l' intégration de votre code dans mon fichier: Je n ai pas le bouton CmdQuit de mon coté sur mon usf ( appelée fenêtre2 chez moi ) ( sur mon fichier ) , jai donc enlever tout les evenements ( .Click entre autre ) qui était lié a cet bouton, cela a t il un impact grave ?

Un problème se pose de mon coté , je ne sais pas si cela est lié a ce que je viens d' écrire ci-dessus :

Quand je scroll dans mes combobox , j ai bien l' effet de défilement escomptée , sauf que dans la majorité des cas , des que je commence a scroller , excel plante et je dois fermer mon fichier , qui est récupérée des la réouverture d' excel .

Situation anormale evidemment , vu que cela marche dans votre fichier et pas dans le mien lorsque j' y importe votre code et que je l' adapte au mien.

Qu' en pensez vous ?

Merci d'avance.

Le 21/03/2017 à 19:07

Bonsoir,

J'en pense rien du tout vu que je n'ai pas de 64 bits. Donc j'ai testé en aveugle ce qui explique que j'ai zappé le PtrSafe de la Sub...

Par ailleurs ce code n'est pas de moi et il commence à dater un peu (2012) alors... Excel 2016 !

Ma suggestion est de poser la question sur

https://answers.microsoft.com/fr-fr

Pas d'inconvénient de supprimer le cmdQuit du moment que tu as un autre bouton pour Unload Me.

Si tu te contentes de fermer avec la Croix rouge du UserForm c'est probablement ça qui fait planter Excel.

A+

Le 21/03/2017 à 19:20

Bonsoir

Merci de vos réponses.

Je cherche donc a résoudre ce problème de plantage.

Je vais répondre a votre question : Je n' ai pas de bouton pour fermer l' userform et je n' ai pas de raison de le fermer dans mon cas celui ci s initialise a l'ouverture de mon classeur , se masque lorsque je quitte la feuille auquel il est attachée , pour réapparaitre lorsque je reviens cette même feuille.

L' absence de ce fameux bouton peut il faire en sorte que Excel plante , car du coup une macro continue par exemple de tourner en arriérè plan ?

Si je comprends bien dans votre fichier , tant que l' on ne clique pas sur le bouton OK ( evenment CmdQuit_Click ) une partie de la macro continue de tourner ?

Merci d'avance.

Le 21/03/2017 à 20:29

Je serais tenté de dire non, mais comme je ne suis pas spécialiste de ce genre de sport...

Ce n'est pas l'absence du bouton qui me fait dire que ça pourrait planter mais l'appui sur la croix rouge... Mais si tu me dis que tu ne t'en sers pas, j'ai tout faux !

D'un autre coté je ne sais pas jusqu'à quel point le fait de masquer le usf ne risque pas de poser problème en mode 64.

Chez moi aucune de ces modifs ne pose problème maintenant je ne sais pas jusqu'à quel point on peut se contenter de PtrSafe pour assurer la compatibilité.

Je ne suis d'ailleurs pas certain que ces macros sont utilisable tel quel en mode 64. Encore une fois c'est juste une tentative de conversion avec PtrSafe que j'ai fait, à partir d'un code prévu pour 32 bits donc je ne peux pas m'avancer plus que ça.

Mais je crois me souvenir qu'un intervenant très présent sur le lien que je t'ai donné maitrise bien cette problématique.

Nota :

essaie d'editer la :

Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT

et mettre :

Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT

A+

Le 21/03/2017 à 20:42
galopin01 a écrit :

Je serais tenté de dire non, mais comme je ne suis pas spécialiste de ce genre de sport...

Ce n'est pas l'absence du bouton qui me fait dire que ça pourrait planter mais l'appui sur la croix rouge... Mais si tu me dis que tu ne t'en sers pas, j'ai tout faux !

D'un autre coté je ne sais pas jusqu'à quel point le fait de masquer le usf ne risque pas de poser problème en mode 64.

Chez moi aucune de ces modifs ne pose problème maintenant je ne sais pas jusqu'à quel point on peut se contenter de PtrSafe pour assurer la compatibilité.

Je ne suis d'ailleurs pas certain que ces macros sont utilisable tel quel en mode 64. Encore une fois c'est juste une tentative de conversion avec PtrSafe que j'ai fait, à partir d'un code prévu pour 32 bits donc je ne peux pas m'avancer plus que ça.

Mais je crois me souvenir qu'un intervenant très présent sur le lien que je t'ai donné maitrise bien cette problématique.

Nota :

essaie d'editer la :

Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT

et mettre :

Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT

A+

Bonsoir

J' ai deja effectué cette manipulation , sans succes malheureusement .

Effectivement peut etre que certaines APIs ne sont pas supportés en 64 bit , mais la je suis dans les choux car je ne suis pas assez connaiseur en la matiere...

Le 21/03/2017 à 20:52

C'est peut-être plus complexe que cela... J'ai systématiquement tout passé en LongPtr mais je ne suis pas du tout convaincu que certaines variable ne doivent pas rester en Long... Dans d'autre situations il faut analyser ce qui doit être changé ou pas... Mais je ne suis pas assez callé pour le faire.

De même dans la :

Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

ça ne m'étonnerai pas que l'une ou l'autre des variables ne doive pas être déclaré en LongPtr (en particulier mouseData ou dwExtraInfo...)

Si tu trouves la solution, ça serait aimable de me faire un retour...

A+

Le 21/03/2017 à 22:50

Je peux reprendre ton exemple et essayer de voir ce que je peux en faire ...

Le 22/03/2017 à 06:09

Je te donne les corrections que j'en ai déduit après moulte recherches... (toujours avec les mêmes réserves !)

Option Explicit
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 Long) As LongPtr

Private Declare 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 Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" _
   (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr 
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _
   (ByVal hHook As LongPtr) 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 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 Long, 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
Le 22/03/2017 à 09:25

Bonjour

Ce code c est juste pour le module ?

Dans L' userform pas besoin de changer quoi que ce soit ?

Le 22/03/2017 à 11:00

Non, Non... Enfin juste les 3-4 lignes relatives au cmdQuit.

J'ai eu par ailleurs une hypothèse de travail qui ne me se semble pas complètement invraisemblable : Je te la livre pour ce qu'elle vaut (c'est à dire juste la peine d'essayer !)

Reprendre tout le code d'origine et remplacer tous les "LongPtr" par des "Long" selon l'auteur... il semblerait que l'ajout des PtrSafe suffisent...

Pour le coup tu pourrais alors remettre dans CallNextHookEx : lParam As Any

A+

Rechercher des sujets similaires à "win bit scolling combobox usf"