Autres tester le scroll de la frame

patricktoulon

XLDnaute Barbatruc
bonjour à tous
est ce que plusieurs d'entre vous pourraient tester le scroll de la frame avec la mollette sur des versions 365 2019 et 2021 svp
merci pour les retours
 

Pièces jointes

  • scrollexemple 2.xlsm
    25.8 KB · Affichages: 12

patricktoulon

XLDnaute Barbatruc
ok merci @Cousinhub
donc un code qui fonctionnais hier ne fonctionne plus aujourd'hui
car c'est toujours le même code que celui qui a été corrigé par chatgpt
j'ai seulement ajouté les autres controls
on peut donc conclure que
soit il manque quelque chose pour les 64
soit alors c'est un bug insoluble et que malheureusement les 64 vous ne pouvez plus hooker la mouse (et sans doute d'autre choses aussi)
ce qui m’étonne c'est que sur le mon portable avec 2016 64 bits je n'ai pas de soucis
 

fanch55

XLDnaute Barbatruc
ok merci @Cousinhub
donc un code qui fonctionnais hier ne fonctionne plus aujourd'hui
car c'est toujours le même code que celui qui a été corrigé par chatgpt
j'ai seulement ajouté les autres controls
on peut donc conclure que
soit il manque quelque chose pour les 64
soit alors c'est un bug insoluble et que malheureusement les 64 vous ne pouvez plus hooker la mouse (et sans doute d'autre choses aussi)
ce qui m’étonne c'est que sur le mon portable avec 2016 64 bits je n'ai pas de soucis
Je suis en w11, il y a eu beaucoup de changements dans l'affichage de toutes les fenêtres par ailleurs assez exaspérants pour certaines applications. ....
 

patricktoulon

XLDnaute Barbatruc
re
bonjour @fanch55
oui mais de la a nous faire des cochonneries pareilles ça devient absurde
je sais plus quoi faire si ce n'est qu'enlever cette option de mon application
ou de la mettre interruptible
tu a testé en le coupant au unhookmouse comme je l'ai montré dans la ressource ?
 

patricktoulon

XLDnaute Barbatruc
re
bonjour @Dudu2 le problème c'est que ta ressource c'est chez moi qu'elle fait cracher excel
donc c'est bonnet blanc blanc bonnet
et a ce que je constate depuis une semaine ici et dans 4 autres mondes excel
c'est que beaucoup même avec des versions récentes d'excel sont en 32 bits (j'aurais pensé le contraire)

intégrer les frames c'est pas ce qu'il y a de plus compliqué
 

patricktoulon

XLDnaute Barbatruc
@patricktoulon,
A la place d'une Frame tu peux pas utiliser une TextBox ?
je comprends pas bien ta question dans le contexte là
je scroll tout controls avec ma version c'est pas le problème
d'ailleurs l"exemple textbox y est aussi
bien que pour ce dernier je ne suis pas complétement satisfait qui m'oblige a scroller jusque en bas ou en haut avant de le voir défiler mais bon c'est pas le plus important
le plus important , c'est les versions récentes d'excel en 64 qui semblent avoir des soucis de buffering
 

patricktoulon

XLDnaute Barbatruc
Ok je savais pas !
ben si je te l'ai dis ca me fait exactement pareil que vous
des fois oui des fois non et au mieux(quand ça se passe bien) le scroll est saccadé
ça fait un effet de repaint control(clignoter le texte dans les listboxs et autre controls liste)
après le 32 bits tout passe donc le 32 n'est pas vraiment en prendre en compte puisque même pour 2010 2013 2016 en 32 les api en vb6 suffisent (testé et retesté de sur! de sur!)
 

fanch55

XLDnaute Barbatruc
ben si je te l'ai dis ca me fait exactement pareil que vous
des fois oui des fois non et au mieux(quand ça se passe bien) le scroll est saccadé
ça fait un effet de repaint control(clignoter le texte dans les listboxs et autre controls liste)
après le 32 bits tout passe donc le 32 n'est pas vraiment en prendre en compte puisque même pour 2010 2013 2016 en 32 les api en vb6 suffisent (testé et retesté de sur! de sur!)
Ce qui est dommage, c'est de ne pas avoir les mêmes Textbox en Excel qu' Access.
Sur Access, le scrolling est natif maintenant .
 

patricktoulon

XLDnaute Barbatruc
re
peut être faire apel a dysorthographie pour ça le king of the king des passerelle vb6
je n'ai plus visual studio sur ce pc je ne peux plus le faire je n'ai plus les SDK d'ailleurs
mais je suis sur que ça l'amuserait de faire ça
le scroll serait géré en VB et plus en vba
 

patricktoulon

XLDnaute Barbatruc
bon allez on essaie de faire mieux
on va essayer de gérer les erreurs non critiques et les erreurs critiques

1° les erreur non critique on sort tout simplement comme c'est au move des control ben ca va être relancé par le prochain mouvement

2° là déjà c'est plus dur ça cogne sec
le on error goto envoie a l'etiquette errorCritique on saute donc deux exit function
et il va justement me renvoyer à l'etiquette nettoyage pour tout cogner bien bien fort
' et renvoyer le hook chez sa mère et en démarrer un tout neuf
voila

VB:
'*****************************************************************************************************

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'*******************************************
'hook mouse simplifié (mollete souris)
'
'Author:patricktoulon
'-------------------------------------
'Exemple d'appel dans userform
'L'object appelant peut être un control dans le control à scroller
'
'Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'------------------------------------
'code indenté avec Vba Indenter 3.1
'**********************************

Option Explicit

Type POINTAPI
    X As Long
    Y As Long
End Type

#If Win64 Then
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As LongPtr
End Type
#Else
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
#End If

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

Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A

Public udtlParamStuct As MSLLHOOKSTRUCT

#If Win64 Then
    Public plHooking As LongPtr    ' To know if the hook is active or not
#Else
    Public plHooking As Long       ' To know if the hook is active or not
#End If

Public CtrlHooked As Object    ' Will be associated with the ListBox
Public pos As POINTAPI
Public EpC As Variant
Public PosY As Long

Sub rouletambour(obj)
    ' Start the hook if it hasn't started yet
    If Not CtrlHooked Is Nothing Then
        If CtrlHooked.Name <> obj.Name Then UnHookMouse
    End If
    Call HookMouse(obj)
End Sub

Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function

#If Win64 Then
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
#Else
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
On Error GoTo ErrorCritique    ' Improved error handling

Dim Criter As Boolean, i&, Mdata
GetCursorPos pos
Criter = plHooking <> 0 'si le thread plhooking <>0 c'est bon
Criter = Criter And IsArray(EpC) 'si EpC est un array c'est bon
Criter = Criter And Not CtrlHooked Is Nothing 'si CtrlHooked n'est pas nothing c'est bon
Criter = Criter And wParam <> 0 'si wparam <>0alors la struture  de la mouse  a été captée
'et en fin si les coordonnées sont dans le rectangle corespondant au corordonnées du rectangle du control  c'est bon
Criter = Criter And pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3)    ' Get control's coordinates in pixels

If Not Criter Then UnHookMouse: Exit Function 'possibilité non critique criter est false alors on sort(le move sur control refera un nouvel appel)
If (nCode = HC_ACTION) Then 'si ncode renvoie bien action alors on est bon la structure est captée
    If wParam = WM_MOUSEWHEEL Then 'si wparam renvoie bien 522 soit &H20A  alors la structure est bonne
        LowLevelMouseProc = True 'alors on est true(32 bits relance le hook en looping (pas le 64)
        Mdata = GetHookStruct(lParam).mouseData 'on récupère le mouse data
        With CtrlHooked
            CtrlHooked.SetFocus
           'selon le control appellant (ou designé)
            'on testera le typeof et le typename selon les configs typeof renvoie une mauvaise reponse
            Select Case True
                Case TypeOf CtrlHooked Is Frame Or TypeName(CtrlHooked) = Frame
                    If Mdata > 0 Then .ScrollTop = .ScrollTop - 45 Else .ScrollTop = .ScrollTop + 45
               
                Case TypeOf CtrlHooked Is ListBox Or TypeName(CtrlHooked) = "ListBox"
                    If Mdata > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
               
                Case TypeOf CtrlHooked Is ComboBox Or TypeName(CtrlHooked) = "ComboBox"
                    If Mdata > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
               
                Case TypeOf CtrlHooked Is TextBox Or TypeName(CtrlHooked) = "TextBox"
                    If Mdata > 0 Then
                        CtrlHooked.CurLine = Application.Max(0, CtrlHooked.CurLine - 2)
                    Else
                        CtrlHooked.CurLine = Application.Min(CtrlHooked.LineCount - 1, CtrlHooked.CurLine + 2)
                    End If
               
                Case TypeOf CtrlHooked Is ScrollBar Or TypeName(CtrlHooked) = "ScrollBar"
                    If Mdata > 0 Then .Value = .Value - 1 Else .Value = .Value + 1
            End Select
        End With
    End If
    Exit Function 'ici on sort tout c'est bien passé
End If
'----------------------------------'
'Gestion d'erreur critique dans un switch entre deux exit function
Nettoyage: 'ici on a été renvoyé par errorCritique
    If Err.Number <> 0 Then Err.Clear: UnHookMouse
    On Error GoTo 0
    LowLevelMouseProc = CallNextHookEx(plHooking, nCode, wParam, lParam) 'évidemment là on est obligé de rappeller car tout est mort ,dead ,ralbate ,crevé etc...
    Exit Function ' on sort on va pas boucler sur une erreur ca suffit une fois espece de saucisse!!!!

ErrorCritique:
    MsgBox "Une erreur est survenue pendant hook " & vbCrLf & Err.Description, vbCritical
    Resume Nettoyage ' on renvoie au nettoyage pour tout nettoyer et relancer avec callnexthook neccessaire cette fois ci car externe à la partie ou tout se passe bien
End Function

Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
    If plHooking < 1 Then    ' active le hook si un autre n'est pas démarré
        EpC = EmplacementControl(ControlToScroll)    ' Get the control's rectangle relative to the screen (not the parent) into an array
        Set CtrlHooked = ControlToScroll
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    End If
End Sub

Public Sub UnHookMouse()
    ' Déactive le hook si un thread(plHooking) a été précédemment démarré
    If plHooking <> 0 Then
        UnhookWindowsHookEx (plHooking)
        plHooking = 0
        Set CtrlHooked = Nothing
    End If
    PosY = 0
End Sub

' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
    If Not obj Is Nothing Then
        Dim Lft As Double, Ltop As Double, plus, ParentX As Object, ParentXInsWidth As Double, ParentXInsHeight As Double, K As Double, PPx, A, z
        With CreateObject("WScript.Shell")
            PPx = 1 / (.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72)
        End With
        If Not TypeOf obj.Parent Is Worksheet And Not TypeName(obj) = "WorkSheet" Then
            If PosY > obj.Height Then plus = (obj.Font.Size / 0.75 - 1) * obj.ListRows Else plus = 0
            Lft = obj.Left
            Ltop = obj.Top    ' Normalement Page, Frame ou UserForm
            Set ParentX = obj.Parent
            Do
                ParentXInsWidth = ParentX.InsideWidth    ' Le Page en est pourvu, mais pas le Multipage
                ParentXInsHeight = ParentX.InsideHeight
                If TypeOf ParentX Is MSForms.Page Then Set ParentX = ParentX.Parent    ' Prend le Multipage, car le Page est sans positionnement
                K = (ParentX.Width - ParentXInsWidth) / 2
                Lft = (Lft + ParentX.Left + K)
                Ltop = (Ltop + ParentX.Top + ParentX.Height - K - ParentXInsHeight)
                If Not (TypeOf ParentX Is MSForms.Frame Or TypeOf ParentX Is MSForms.MultiPage) Then Exit Do
                Set ParentX = ParentX.Parent
            Loop
            EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height + plus) / PPx)
        End If
    Else
        'plus tard !!! pour les oleobject  oleobject in worksheet(voir tuto patricktoulon pointoscreenpixel)
        'Debug.Print Join(EmplacementControl, "-----")
    End If
End Function
hoh !! nounn' di dious!!!
 

Pièces jointes

  • scrollexemple 64 et 32 bits.xlsm
    31.6 KB · Affichages: 2
Dernière édition:

fanch55

XLDnaute Barbatruc
Ajout des double-quotes à Frame :
1716566192362.png

Tout semble bien fonctionner sauf pour la scrollbar où il semblerait qu'on perde le hook au wheelmouse et il faut cliquer sur un autre objet et revenir au scrollbar qui reperd le Hook un peu plus tard et etc ....
finalement, on arrive sur ceci ( sans planter ) : il semblerait qu'on essaye d'aller plus loin que la valeur max du scrollbar ...

1716566510891.png
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
312 843
Messages
2 092 752
Membres
105 520
dernier inscrit
Inconnuto