Complément (Vba Indenter Interface) 4.0b

[fanch55]

non tu la trouve dans des vielles discussion celle là c'est un truc compliqué


a tu corrigé les deux erreur toute bêtes ,comme je te l'ai expliqué?

alors comment j'ai fait pour le scroll
au départ
1° je met mes deux textbox dans une frame
2°dans mes boutons (partout a chaque fois q"un menu doit apparaitre je le met ".Zorder 0"
par ce que comme la frame contenant les deux textbox est nouvelle elle passe par dessus

3°ensuite puisque tu veux automatique je lâche le keydown sur touche CTRL pour le mouse move sur les deux textboxs
4°quand je load un module je met le scrollheight de la frame au nombre de ligne *15(ya un peu de marge)
quand j'indente forcement aussi
le reste pour la sortie on reprend ma fonction magique du calendar (voir aussi infobulle)
et par pitié sans do/loop(petite dédicace à dudu 🤣 🤣 )
comme on a le levelmouse qui tourne en boucle en addressof
ben on fait le test dedans c'est tout
terminé
le code du scroll a tester dans un userform vierge

J'ai beau essayer d'adapter ton code au 64 bits ( longptr au lieu de long ) pour certaines variables, le résultat n'est pas au rdv : le pointeur se balade un peu n'importe où puis excel se plante ...

 

[patricktoulon]

quel pointeur?

je te fait un exemple tout simple est ce que celui là te fait planter aussi ?
après peut être que les déclarations sont mal déclarée je sais pas
j'ai trouvé 3 façons de déclarer la rltmovememory

#If Win64 Then
        'Declare PtrSafe Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDst As LongPtr, ByRef pSrc As LongPtr, ByVal length As LongLong)
        'Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As LongPtr)
        Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef dest As Any, ByRef source As Any, ByVal bytes As Long)
    #Else   'vba 7 32 bits
        'Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal source As LongPtr, ByVal length As LongPtr)
    #End If

je te joints un exemple a tester tu a l'userform et tout avec les 3 méthodes
et par la même occasion ton code indenté avec la version 3.1
je te laisse juger de la puissance du nouveau moteur

 

[Nicolas JACQUIN]

Bonjour Pat,

En ouvrant l'userform de scrollexemple, ça à carrément crasher excel, il me semble avoir aperçu RtlMoveMemory juste avant le crash

A voir avec d'autres

a+

 

[patricktoulon]

oui je sais il faut essayer les 3 pour 64 je ne sais pas le quel est le bon

 

[fanch55]

oui je sais il faut essayer les 3 pour 64 je ne sais pas le quel est le bon

Bon, moi ça ne crache plus avec les correction ci-dessous ,
par contre je ne peux que descendre dans la frame, pas monter ....

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'*******************************************
'muti hook mouse simplifié (molete souris sur frame)
'défilement dans controls liste frame
'author:patricktoulon

' Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************

Option Explicit
#If VBA7 Then
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal Length As Long)
    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 LongPtr, lParam As Any) 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
    Public plHooking As LongPtr         ' permet de savoir si le hook est activé ou pas
#Else
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal source As Long, ByVal length As Long)
    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
    Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Public plHooking As Long         ' permet de savoir si le hook est activé ou pas
#End If

Type POINTAPI: X As Long: Y As Long: End Type
Type MSLLHOOKSTRUCT: pt As POINTAPI: mouseData As Long: flags As Long: time As Long: dwExtraInfo As Long: End Type
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Public udtlParamStuct As MSLLHOOKSTRUCT
Public CtrlHooked As Object         ' sera associé à la ListBox

Public pos As POINTAPI
Public EpC As Variant


'**********************************
'à mettre dans la frame ou le control qui est sensé le déclencher
'ce peut être un control à l'interieur de la frame
' Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************

Sub rouletambour(obj)
    'si ca n'a pas démarrer on demarre  le hook
    If Not CtrlHooked Is Nothing Then If CtrlHooked.Name <> obj.Name Then UnHookMouse
    Call HookMouse(obj)
End Sub
'
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
#If VBA7 Then
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As Long) As LongPtr
#Else
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
    On Error Resume Next    'en cas de mouvement très rapide,'évitons les crash en désactivant les erreurs
    Dim Criter
    GetCursorPos pos
    Criter = pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3)    'recupère les coordonnée en pixel (left/top/right/bottom du control)
    If Not Criter Then UnHookMouse  'quand on est plus dans le périmètre du control bye bye !!
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 45 Else .ScrollTop = .ScrollTop + 45
            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é
        EpC = EmplacementControl(ControlToScroll)    'on choppe le rectangle du control par raport à l'ecran(pas du parent!!!!) du control dans un array
        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
' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
    If Not obj Is Nothing Then
        Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, K As Double, PPx, A, z
        Lft = obj.Left: Ltop = obj.Top: Set P = obj.Parent    ' Normalement Page, Frame ou UserForm
        PPx = 0.75    'utilisez ici la méthode pour choper votre coeff point/pixel
        Do
            PInsWidth = P.InsideWidth: PInsHeight = P.InsideHeight        ' Le Page en est pourvu, mais pas le Multipage.
            If TypeOf P Is MSForms.Page Then Set P = P.Parent        ' Prend le Multipage, car le Page est sans positionnement.
            K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.Left + K): Ltop = (Ltop + P.Top + P.Height - K - PInsHeight)
            If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
            Set P = P.Parent
        Loop
        EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height) / PPx)

    End If
End Function

 

[patricktoulon]

et oui c'est celle avec les "any" je sais moi aussi ca fait pareil elle marche que en descente

 

[patricktoulon]

en tout cas il faut trouver je peux pas distribuer sans ça maintenant

 

[patricktoulon]

@fanch55 tu a regardé au fait le fichier txt ?

 

[fanch55]

@fanch55 tu a regardé au fait le fichier txt ?

Oui, mais je ne l'ai pas plus examiné.
Je pars aider mon fils a bricoler 2 jours. A +

 

[patricktoulon]

Ok bon bricolage
je perd un bon acolyte😭
mais c'est pas grave les enfants c'est sacré

 

[fanch55]

Je viens d'examiner à fond le fichier Txt,
Il y a du mieux ( beaucoup ), mais encore qq anomalies que je classe en 2 catégories :
1) customer design ( selon les goûts ) :

2) fonctionnelle :

 

[patricktoulon]

bonjour fanch55

 

[patricktoulon]

pour info voila comment smart indenter indente

et voilà comment vba interface v3.0 indnet sans l'option cochée

et voila avec l'option cochée

 

[patricktoulon]

au fait tu sais pas il y a une autre nouveauté majeure
reste assis hein !!

 

[fanch55]

pour info voila comment smart indenter indente


et voilà comment vba interface v3.0 indnet sans l'option cochée





et voila avec l'option cochée

Ce n'est pas le msgbox qui me taraude, mais le sort ...