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]

Je répondais par rapport aux captures d'écran.

Je n'ai pas encore testé ton code.
Si tu en as un qui permette d'afficher le UserForm au bon endroit, donc à l'endroit où on a cliqué, ça m'intéresse.

Je répondais par rapport aux captures d'écran.

Je n'ai pas encore testé ton code.
Si tu en as un qui permette d'afficher le UserForm au bon endroit, donc à l'endroit où on a cliqué, ça m'intéresse.

Vous avez cas essayé !!

 

[TooFatBoy]

Vous avez cas essayé !!

Cause-moi meilleur !!

 

[Nicolas JACQUIN]

un truc qui marche à 100 % pour tous c'est que ce n'est pas possible

J'ai pas dis que c'était un code qui marchais à 100% à la base, c'était juste pour voir chez qui ça fonctionnait

 

[Nicolas JACQUIN]

Cause-moi meilleur !!

Je vous ai juste demandé d'essayer

 

[patricktoulon]

re

regarde Nicolas

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim pos
    pos = PositionForm_V_Pat(ActiveCell)
    With UserForm1
        MsgBox .Width - .InsideWidth
        .Show 0
        .Move pos(0), pos(1)
    End With
End Sub
Function PositionForm_V_Pat(rng As Range)
    Dim Z#, LpP#, TpP#, HpP#, WpP#
    With ActiveWindow
        Z = .Zoom / 100
        ppx = 1 / ((.Panes(1).PointsToScreenPixelsX(7200 / Z) - .Panes(1).PointsToScreenPixelsX(0)) / 7200)
        If Mac Then ppx = 1
        LpP = .ActivePane.PointsToScreenPixelsX(rng.Left) * ppx
        ' - 1.5
        TpP = .ActivePane.PointsToScreenPixelsY(rng.Top) * ppx
    End With
    PositionForm_V_Pat = Array(LpP, TpP)
End Function

allez regarde ça

alors ils sont bons mes drivers ou pas Saucisse !!!

 

[Dudu2]

A titre indicatif, voici un code qui corrige le visuel en tenant compte des marges du UserForm en utilisant de l'API qui avait été élaboré avec @patricktoulon il y a pas mal de temps. Comme quoi on se repose toujours les mêmes questions !

Ça devrait en principe fonctionner partout ou presque. A vérifier.

Note: perso j'utilise les conversions Pixels / Points orthodoxes via API pour éviter les ennuis.

 

[patricktoulon]

re
@Dudu2
nicolas connais
il y était quand on avait fait ça avec pijaku su DVP
mais il a oublié

 

[Nicolas JACQUIN]

A titre indicatif, voici un code qui corrige le visuel en tenant compte des marges du UserForm en utilisant de l'API qui avait été élaboré avec @patricktoulon il y a pas mal de temps. Comme quoi on se repose toujours les mêmes questions !

Ça devrait en principe fonctionner partout ou presque. A vérifier.

Note: perso j'utilise les conversions Pixels / Points orthodoxes via API pour éviter les ennuis.

 

[Nicolas JACQUIN]

Je vais en rester là, ça me convient avec ce que j'en fait.
Merci pour vos retour.

 

[patricktoulon]

re
et oui bien sur c'est nickel avec ça

@Dudu2 il faut enlever le "-1.5" quand même il faut le dire

 

[Nicolas JACQUIN]

A Patrick, juste pour te montrer chez moi, mais j'en reste là, c'est sur je suis pas calé comme vous mais têtu oui.

 

[patricktoulon]

Tiens @Dudu2 une version un peu plus condensée
pour tester met tout dans la feuille et met un userform

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As LongPtr, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
#Else
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
#End If

Private Enum DWMWINDOWATTRIBUTE
    DWMWA_NCRENDERING_ENABLED = 1
    DWMWA_NCRENDERING_POLICY
    DWMWA_TRANSITIONS_FORCEDISABLED
    DWMWA_ALLOW_NCPAINT
    DWMWA_CAPTION_BUTTON_BOUNDS
    DWMWA_NONCLIENT_RTL_LAYOUT
    DWMWA_FORCE_ICONIC_REPRESENTATION
    DWMWA_FLIP3D_POLICY
    DWMWA_EXTENDED_FRAME_BOUNDS
    DWMWA_LAST
End Enum
Private Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type

Private Function ecart(Lcaption$, UfLeft#, UfTop#) As RECT
    Dim rectangle As RECT, HandleUsF As Long, ppx#, z
    With ActiveWindow
        z = .Zoom / 100
        ppx = ((.Panes(1).PointsToScreenPixelsX(72) - .Panes(1).PointsToScreenPixelsX(0)) / 72) / z
    End With
    ecart.Left = 0: ecart.Top = 0
    HandleUsF = FindWindowA(vbNullString, Lcaption)
    DwmGetWindowAttribute HandleUsF, DWMWA_EXTENDED_FRAME_BOUNDS, rectangle, LenB(rectangle)
    ecart.Left = IIf(rectangle.Left / ppx <> 0, UfLeft - (rectangle.Left / ppx), 0)
    ecart.Top = IIf(rectangle.Top / ppx <> 0, UfTop - (rectangle.Top / ppx), 0)
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim pos, Ecx As RECT, x&
    pos = PositionForm_V_Pat(ActiveCell)
    With UserForm1
        .Show 0
        Ecx = ecart(.Caption, .Left, .Top)
        .Move pos(0) + Ecx.Left, pos(1) + Ecx.Top
    End With
End Sub
Function PositionForm_V_Pat(rng As Range)
    Dim z#, LpP#, TpP#, HpP#, WpP#, ppx#
    With ActiveWindow
        z = .Zoom / 100
        ppx = 1 / ((.Panes(1).PointsToScreenPixelsX(7200 / z) - .Panes(1).PointsToScreenPixelsX(0)) / 7200)
        #If Mac Then
            ppx = 1
        #End If
        LpP = .ActivePane.PointsToScreenPixelsX(rng.Left) * ppx
        TpP = .ActivePane.PointsToScreenPixelsY(rng.Top) * ppx
    End With
    PositionForm_V_Pat = Array(LpP, TpP)
End Function

 

[Dudu2]

@Dudu2 il faut enlever le "-1.5" quand même il faut le dire

Ah oui, l'avais pas vu celui-là !
J'ai modifié le fichier juste pour ça.

 

[patricktoulon]

re on a vieilli Nicolas de 10 ans là d'un coup

 

[TooFatBoy]

Je vous ai juste demandé d'essayer

J'essaye dès que j'ai un PC sous la main.