XL 2016 Position userform dans coin supérieur gauche de cellule 2016 et+

Nicolas JACQUIN · 31 Mars 2024

Bonjours tout le monde,

Je me permets de ressortir un sujet qui revient assez souvent mais sans vraiment coller pour chacun.
Le placement d'un userform dans le coin supérieur gauche d'une cellule sélectée.

Depuis 2017, avec Patrick on a travaillé sur le sujet un bon moment sans réel succès selon les configurations,
avec souvent une erreur de -5 au left en rapport avec le cadre de l'userform.

Pour ma part, fonctionne sur:

- Excel 2016, 2019, 2021 32 bits sous W10 64bits
- Mode fenêtre ou pleine écran
- Avec ou sans Zoom
- Colonne + ou - réduite

Je vous laisse donc juger.

Voici déjà une fonction,

VB:

Function PositionForm(FORM As Object, rng As Range)
With CreateObject("WScript.Shell"): Ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
With FORM: bord = ((.InsideWidth - .Width) / 2) + 1: End With
    With ActiveWindow
        Zom = .Zoom / 100
        lleft = .PointsToScreenPixelsX(rng.Left * Ppx * Zom) / Ppx + bord
        ttop = .PointsToScreenPixelsY(rng.Top * Ppx * Zom) / Ppx
        Hheight = (rng.Height * Ppx) / Ppx * Zom - bord
        Wwidth = (rng.Width * Ppx) / Ppx * Zom - bord * 2
    End With
PositionForm = Array(lleft, ttop, Hheight, Wwidth)
End Function

Sub placement_form1()
    R = PositionForm(UserForm1, ActiveCell)
    With UserForm1: .Show 0: .Left = R(0): .Top = R(1): End With
End Sub

Sub placement_form2()
    R = PositionForm(UserForm1, Range("F17"))
    With UserForm1: .Show 0: .Left = R(0): .Top = R(1): End With
End Sub

Sub placement_form3()
    R = PositionForm(UserForm1, Range("I9:N25"))
    With UserForm1: .Show 0: .Left = R(0): .Top = R(1): .Height = R(2): .Width = R(3): End With
End Sub

Sub placement_form4()
    R = PositionForm(UserForm1, Range("C4:I20"))
    With UserForm1: .Show 0: .Left = R(0): .Top = R(1): .Height = R(2): .Width = R(3): End With
End Sub

Sub placement_form5()
    R = PositionForm(UserForm1, Range("N4:P31"))
    With UserForm1: .Show 0: .Left = R(0): .Top = R(1): .Height = R(2): .Width = R(3): End With
End Sub

Et une Sub,

Code:

Sub Placement_form6()
With CreateObject("WScript.Shell"): Ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    With UserForm1
        bord = ((.InsideWidth - .Width) / 2) + 1
            With ActiveWindow
                Zom = .Zoom / 100
                lleft = .PointsToScreenPixelsX(ActiveCell.Left * Ppx * Zom) / Ppx + bord
                ttop = .PointsToScreenPixelsY(ActiveCell.Top * Ppx * Zom) / Ppx
            End With
        .Show 0
        .Left = lleft
        .Top = ttop
    End With
End Sub

Donc si ça fonctionne chez vous, n'hésitez pas à laisser votre configuration, ça permettra de voir.
Merci à tous.

Nicolas

Nicolas JACQUIN · 3 Avril 2024

En gros j'ai juste modifié ta ligne ppx pour que ça colle chez moi, je sais pas pourquoi mais tout fonctionne, n'importe le zoom
Et le fameux écart bien sûre

patricktoulon · 3 Avril 2024

re
@Nico_J , @Dudu2 , @TooFatBoy

@Nico_J donne moi ta ligne modifiée

Nicolas JACQUIN · 3 Avril 2024

patricktoulon à dit:
re
@Nico_J , @Dudu2 , @TooFatBoy

@Nico_J donne moi ta ligne modifiée

moi: PpX = 1 / ((.Panes(1).PointsToScreenPixelsX(7200 / Z) - .Panes(1).PointsToScreenPixelsX(0)) / 7200)
toi: PpX = Round(1 / ((.Panes(1).PointsToScreenPixelsX(7200 / Z) - (.Panes(1).PointsToScreenPixelsX(0) * Z)) / 7200), 2)

patricktoulon · 3 Avril 2024

re ça change quasiment rien chez moi
en tout cas a vue d’œil
je le met par ce que c'est plus logique( à moitié) car le zoom grossi les headers aussi mais en réalité la différence est d'un demie point soit imperceptible à l’œil nu

Nicolas JACQUIN · 3 Avril 2024

Je déconne pas, je t'ai montré les pitite vidéo

Nicolas JACQUIN · 3 Avril 2024

Code tel quel

VB:

Option Explicit
Function PositionForm_V_Pat(FORM As Object, rng As Range, Optional Indexpan As Long = 0)
    Dim Z#, LpP#, TpP#, HpP#, WpP#, I%, Marge#, PaN As Pane, PpX#
    '----------------------------
    ' je vous laisse  décider de la méthode de redressage
    'chez moi
    'Marge = 5
    With FORM: Marge = Round(((.Width - .InsideWidth) / 2) - 1, 0): End With

    '---------------------------
    With ActiveWindow

        If Indexpan > .Panes.Count Then MsgBox " il n'y a pas de panes(" & Indexpan & ")": Exit Function
       If Indexpan = 0 Then Set PaN = .ActivePane Else Set PaN = .Panes(Indexpan)
        If Intersect(PaN.VisibleRange, rng) Is Nothing Then
            For I = 1 To .Panes.Count
                If Not Intersect(.Panes(I).VisibleRange, rng) Is Nothing Then Set PaN = .Panes(I)
            Next
        End If
        If Indexpan > 0 Then If PaN.Index <> Indexpan Then MsgBox " la range " & rng.Address(0, 0) & _
         " n'est pas  dans la pane(" & Indexpan & ") mais en panes(" & PaN.Index & ")"

        Z = .Zoom / 100
        PpX = 1 / ((.Panes(1).PointsToScreenPixelsX(7200 / Z) - .Panes(1).PointsToScreenPixelsX(0)) / 7200)
        LpP = PaN.PointsToScreenPixelsX(rng.Left) * PpX - Marge
        TpP = PaN.PointsToScreenPixelsY(rng.Top) * PpX
        
        HpP = IIf(rng.Cells.Count > 1, rng.Height * Z + Marge, 200)
        WpP = IIf(rng.Cells.Count > 1, rng.Width * Z + (Marge * 2), 200)
        
        With FORM: .Label1.Caption = "Marge : ((.InsideWidth - .Width) / 2) -1  = " & Marge: End With

    End With
    PositionForm_V_Pat = Array(LpP, TpP, WpP, HpP)
End Function

patricktoulon · 3 Avril 2024

ben oui ça marche
la seule chose que vous avez a faire c'est la "Marge"

Nicolas JACQUIN · 3 Avril 2024

patricktoulon à dit:
ben oui ça marche
la seule chose que vous avez a faire c'est la "Marge"

avec la modif ppx que j'ai faite, on est d'accord ??

TooFatBoy · 3 Avril 2024

Nico_J à dit:
je cherche juste à comprendre et apprendre, y a rien de méchant.

Ah cool, on est donc exactement dans le même cas.

Donc si tu piges des trucs, tu pourras me les expliquer ?
Attention, il faut aller lentement pour que je comprenne...

patricktoulon · 3 Avril 2024

re
qu'est ce que tu comprends pas @TooFatBoy?

TooFatBoy · 3 Avril 2024

patricktoulon à dit:
re
qu'est ce que tu comprends pas @TooFatBoy?

Je dirais... TOUT, hélas !

TooFatBoy · 3 Avril 2024

Au fait, merci pour le code de #73 !

Modifié comme ceci :

VB:

Sub test()
    dpi = dpix
    MsgBox "dpi reg. = " & dpi & vbCrLf & _
           "Pt to px = " & PointToPixel(dpi) & vbCrLf & _
           "Px to pt = " & PixelToPoint(dpi)
End Sub

Ca donne ça :

patricktoulon · 3 Avril 2024

ben c'est juste
tu est donc en 100% et ton coeff c'est bien 0.75

après tu dis que tu comprends rien
est ce que cela tu l'a compris au moins

TooFatBoy · 3 Avril 2024

Non, je n'ai pas du tout compris ne serait-ce que ça.

patricktoulon · 3 Avril 2024

ben le code de chaque couleur donne en pixel la distance des flèches dessinées
ce qui fait que pour le userform qui attends des points et non des pixels il faut convertir
le dessin n'est pas clair ?

XL 2016 Position userform dans coin supérieur gauche de cellule 2016 et+

Nicolas JACQUIN

XLDnaute Impliqué

Pièces jointes

Nicolas JACQUIN

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

Nicolas JACQUIN

XLDnaute Impliqué

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Nicolas JACQUIN

XLDnaute Impliqué

TooFatBoy

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires