Autres [Résolu]Affichage userform sur cellule ou activX version simplifiée a tester

patricktoulon · 8 Septembre 2019

bonjour suite a deux discussions ressentes j'ai repris ma méthode et je l'ai simplifiée
normalement avec cette méthode on est dédouané du calcul et prise en charge du freezepane et des scrollbars H et V

aucune Api window ou gdi !!
aucun chiffre en dur dans le code !!!
aucun calcul des scroll ou du freezepane
et l'userform est contraint dans le périmètre de la fenêtre application si il le dépasse
vous voulez bien tester
cellule a jumeler

activx a jumeler

patricktoulon · 14 Septembre 2019

j'ai autre chose a te proposer
je pense qu'il ne reste plus qu'a appliquer ce qui est dit en A1:A2

est tu d'accords avec ca ?

Roland_M · 14 Septembre 2019

re

je viens d'essayer, c'est pas mal !

donc pour l'instant il ne reste plus qu'a appliquer ce qui est dit en A1:A2
pour placer l'userf lorsque l'on clic dans les parties non mobiles, c'est à dire en haut et à gauche ?

Roland_M · 14 Septembre 2019

re

donc je solutionne comme ceci qui semble bien fonctionner:
T1 = T1 + (lx.Height * (ActiveWindow.Zoom / 100))
L1 = L1 + (cy.Width * (ActiveWindow.Zoom / 100))

Code:

    'connaitre le nombre de ligne a ratraper en terme de top
    With ActiveWindow
        R = .ScrollRow - .SplitRow - 1
        If .ScrollRow > .SplitRow + 1 And Obj.Row <= .SplitRow Then
            Set lx = Range(Cells(.SplitRow + 1, 1), Cells(.VisibleRange.Row - 1, 1))
            [A1] = "Rows " & lx.EntireRow.Address(0, 0) & " a ratraper) soit " & lx.Height & "points"
            T1 = T1 + (lx.Height * (ActiveWindow.Zoom / 100))
        Else
            [A1] = "0 ligne a ratraper"
        End If
       
        'connaitre le nombre de colonne a ratraper en terme de left
        C = .ScrollColumn - .SplitColumn - 1
        If .ScrollColumn > .SplitColumn + 1 And Obj.Column <= .SplitColumn Then
            Set cy = Range(Cells(1, .SplitColumn + 1), Cells(1, .VisibleRange.Column - 1))
           [A2] = "Columns " & cy.EntireColumn.Address(0, 0) & " a ratraper)soit " & cy.Width & "points"
            L1 = L1 + (cy.Width * (ActiveWindow.Zoom / 100))
        Else
           [A2] = "0 colonne a ratraper"
        End If
    End With

EDIT: Purée, c'est génial !
pile poil sur 2007
sur 2016 ça fonctionne impect aussi, avec comme toujours un peu décalé d'environ 3 points à droite et à gauche
sans aucune importance ! on pourrait régler ça en testant la version, mais si on entre là dedans on a pas fini !
donc à suivre . . . là je suis occupé, après je refais des essais et je t'informe en retour.

patricktoulon · 14 Septembre 2019

re
en effet je pense que ma méthode est bonne reste a la formuler sans faire une usine a gaz avec un code intelligible et accessible a tous
je pense qu'il y a certainement une logique interne a excel mais ca n'est pas une logique mathématique

pour le décalage moi c'est 4 ou 2 + ombre(=2) c'est du poils de chat ceux qui ont W10 c'est 7 car l'ombre y est mais on la voit pas et comme le cadre c'est 1 point de large donc 7-2-1

Roland_M · 14 Septembre 2019

re

c'est ce dont je vais faire, l'arranger à ma sauce selon mes utilisations
mais la formule est bonne !
encore merci pour ta ténacité !

patricktoulon · 14 Septembre 2019

re
pour info je le répète
pointtoscreenpixel(x/y) ne me servent qu'a choper le point 0 du top et left de la grille le reste c'est en point avec les dim des ranges
ca simplifie les opérations et évite d'appliquer des opérateurs a certains éléments comme on le faisait quand on prenait tout avec pointtoscreenpixel
je vais tester ton code avec ma formule

tenace

t' a pas idée!!

acharné serait même plus approprié je crois

je suis cuisiniste et sanitairiste de métier 1 millimetre c'est 1 milimetre

en tout cas avec danreb,toi et moi on a solutionné un truc qui dure depuis des années

y a plus qu'a faire du générique

patricktoulon · 14 Septembre 2019

bon ben voila la totale

position de base top0left 0 de la cel
argument (xlconstante pour le choix de positionnement autour de la cellule
-1 pour le mezo mezo
contrainte pour ne pas sortir de la fentre de l'application

VB:

Private Sub placementRange()
    Dim EcX&, EcY&, L1#, T1#
    EcX = 4    '(Me.Width - Me.InsideWidth)
    EcY = Me.Height - Me.InsideHeight
    If ActiveWindow.Zoom > 100 Then EcX = EcX / (ActiveWindow.Zoom / 100)

    L1 = ((ActiveWindow.ActivePane.PointsToScreenPixelsX(0) / PtoPx) + EcX) * (ActiveWindow.Zoom / 100) + ((Range(Obj, Cells(1, 1)).Width - Obj.Width) * (ActiveWindow.Zoom / 100))
    T1 = ((ActiveWindow.ActivePane.PointsToScreenPixelsY(0) / PtoPx) + EcX) * (ActiveWindow.Zoom / 100) + (Range(Obj.Offset(IIf(Obj.Row > 1, -1, 0)), Cells(1, 1)).Height * (ActiveWindow.Zoom / 100))


    'connaitre le nombre de ligne a ratraper en terme de top
    With ActiveWindow
        R = .ScrollRow - .SplitRow - 1
        If .ScrollRow > .SplitRow + 1 And Obj.Row <= .SplitRow Then
            Set lx = Range(Cells(.SplitRow + 1, 1), Cells(.VisibleRange.Row - 1, 1))
            [A1] = "Rows " & lx.EntireRow.Address(0, 0) & " a ratraper) soit " & lx.Height & "points"
            T1 = T1 + (lx.Height * (.Zoom / 100))
        Else
            [A1] = "0 ligne a ratraper"
        End If

        'connaitre le nombre de colonne a ratraper en terme de left
        C = .ScrollColumn - .SplitColumn - 1
        If .ScrollColumn > .SplitColumn + 1 And Obj.Column <= .SplitColumn Then
            Set cy = Range(Cells(1, .SplitColumn + 1), Cells(1, .VisibleRange.Column - 1))
            [A2] = "Columns " & cy.EntireColumn.Address(0, 0) & " a ratraper)soit " & cy.Width & "points"
            L1 = L1 + (cy.Width * (.Zoom / 100))
        Else
            [A2] = "0 colonne a ratraper"
        End If
        If Obj.Row = 1 Then T1 = T1 - Obj.Height * (.Zoom / 100)
        
        'a la base on est en top et left de obj
        ' donc ici tu ajoute la position autour de cette cellule
        'pour la blague j'utilise des constante excel
        'comme postop et posleft sont public et double elle valent 0 (si non renseigné dans l'apel dans le sheets) donc elle sont optional implicitement
        Select Case posTop
        Case xlBottom: T1 = T1 + Obj.Height * (.Zoom / 100)
           Case xlCenter: T1 = T1 + (Obj.Height * (.Zoom / 100)) / 2
            'etc..etc...
        End Select
        
        Select Case posLeft
        Case xlRight: L1 = L1 + Obj.Width * (.Zoom / 100)
        Case xlCenter: L1 = L1 + (Obj.Width * (.Zoom / 100)) / 2
        Case -1: L1 = L1 - ((Me.Width - Obj.Width) / 2)
            'etc..etc...
        End Select

    End With

    '---------------------------------ICI CONTRAINTE ALTERNATIVE POUR NE PAS SORTIR DE LA FENÊTRE APPLICATION-----------------------------------
    If L1 < Application.Left Then L1 = ((ActiveWindow.ActivePane.PointsToScreenPixelsX(0) / PtoPx) + EcX) * (ActiveWindow.Zoom / 100)
    If L1 > (Abs(Application.Left) + Application.Width - Me.Width) Then L1 = (Application.Left + Application.Width) - Me.Width - EcY
    If T1 > (Abs(Application.Top) + Application.Height - Me.Height) Then T1 = (Application.Top + Application.Height) - Me.Height - EcY
    
    'application des coordonées
    Me.Left = L1
    Me.Top = T1
End Sub

et voila

Roland_M · 14 Septembre 2019

re

excuses de casser l'ambiance mais:
celui-ci ne fonctionne pas du tout !?

quand à celui que j'ai eu auparavant une remarque sur feuille normale:
sur la feuille avec les volets tout est ok
sur la feuille simple lorsque l'on scroll bas et/ou à droite tout décale quand zoom > 100
je vais y regarder !

patricktoulon · 14 Septembre 2019

harhrr!!!!!
tu est sur de ne pas etre dans le contexte de la contrainte ???
bloque les 3 lignes de contrainte pour tester

Roland_M · 14 Septembre 2019

re

non non !

sur la feuille simple c'est quand zoom > 100
donc comme il n'y a pas de volets les tests ne sont pas concernés !
c'est d'ici que ça ce passe si pas de volets
L1 = ((ActiveWindow.ActivePane.PointsToScreenPixelsX(0) / PtoPx) + EcX) * (ActiveWindow.Zoom / 100) + (Range(Obj, Cells(1, 1)).Width * (ActiveWindow.Zoom / 100))
T1 = ((ActiveWindow.ActivePane.PointsToScreenPixelsY(0) / PtoPx) + EcX) * (ActiveWindow.Zoom / 100) + (Range(Obj.Offset(IIf(Obj.Row > 1, -1, 0)), Cells(1, 1)).Height * (ActiveWindow.Zoom / 100))

EDIT: ça doit être en rapport à .ScrollRow et idem colonne ! c'est logique !
donc dans les tests voir à Else pour T1/L1

il y a aussi ceci qui traîne, mais qui ne sert pas!
R = .ScrollRow - .SplitRow - 1
C = .ScrollColumn - .SplitColumn - 1

patricktoulon · 14 Septembre 2019

re
oui j'ai vu ce qui traîne
fait moi plaisir bloque les 3 lignes de contraintes

vue sur sheets normal

Dranreb · 14 Septembre 2019

Bonjour.
Utiliser le moins possible les PointsToScreenPixels, moi je veux bien, mais comment on trouve le Left de la 1ère colonne et le Top de la 1ère ligne dans les parties fixes ?
J'ai un problème avec ça justement dans ma version qui a bien évolué à ce niveau. (Marchait bien, et patatra ! quand j'ai essayer de scroller en B2 avant de figer les volets)

Roland_M · 14 Septembre 2019

re

j'ai solutionné à Else

Code:

        Else
            L1 = ActiveWindow.ActivePane.PointsToScreenPixelsX(Obj.Offset(0, 1).Left) / PtoPx * (ActiveWindow.Zoom / 100)
            [A1] = "0 ligne a ratraper"
        End If

        Else
           T1 = ActiveWindow.ActivePane.PointsToScreenPixelsY(Obj.Top) / PtoPx * (ActiveWindow.Zoom / 100)
           [A2] = "0 colonne a ratraper"
        End If

patricktoulon · 14 Septembre 2019

bonjour danreb

pour les parti fixe tu n'en a pas besoins dans mon model

la base left c'est pointoscreenpixelx(0)/ptpx +ecx *zoom elle est calculée avant et pareil pour le top

Roland_M · 14 Septembre 2019

re

voir ton classeur avec cette correction

Autres [Résolu]Affichage userform sur cellule ou activX version simplifiée a tester

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums