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

[Nicolas JACQUIN]

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,

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,

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]

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]

re
@Nico_J , @Dudu2 , @TooFatBoy

@Nico_J donne moi ta ligne modifiée

 

[Nicolas JACQUIN]

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]

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]

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

 

[Nicolas JACQUIN]

Code tel quel

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]

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

 

[Nicolas JACQUIN]

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]

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]

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

 

[TooFatBoy]

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

Je dirais... TOUT, hélas !

 

[TooFatBoy]

Au fait, merci pour le code de #73 !

Modifié comme ceci :

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]

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]

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

 

[patricktoulon]

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 ?