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

Nicolas JACQUIN

XLDnaute Impliqué
Supporter XLD
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
 

Pièces jointes

  • Placement userform.xlsm
    20.5 KB · Affichages: 13

patricktoulon

XLDnaute Barbatruc
re
@TooFatBoy
perso je parles des résultats que j'obtiens
certes je ne maitrises pas (car ca ne m'intéresse pas) certaines notions de ces choses là
mais le résultat il est là
j'ai testé au boulot ce matin le fichier de Nicolas et le mien sur 7 pc différents pc et écran (marques/dimensions/puissance/etc...)différentes
et bien c'est 50/50
la moitié ont donné a peu près bon avec celui de Nicolas
l'autre moitié avec la mienne avec "-1.5"

j'ai donc cherché les différence mise apart les puissance uc et graphique
je me suis rendu compte que certain etaient en zoom 125 et un en zoom 150 les autres en zoom 100

je parles de ce zoom là pas celui d'excel
1711972164283.png


pour les tests j'ai demandé à ce qu'on les mettes tous à 100%
tout est devenu plus petit sans changer rien d'autre
et j'ai refait les tests
et ben les résultats ont été bien différents
6 sur 7 donnent bon avec simplement -1.5
seul un!! celui de la salle de réunion avec le projecteur que je n'ai pas pu reconfigurer il a fallu -2.4
alors mon bon amis entre ta/tes théorie(s) et la pratique il y a un monde

mais de toute facon ces test je les avais déjà fait et les résultats ont toujours été les mêmes
pour info
la formule de Nicolas chez moi donne
1711972925360.png


si je met -1.25 dans ma formule alors que chez moi c'est 1.5(prouvé par les api hier)
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Z#, LpP#, TpP#
    With ActiveWindow
        Z = .Zoom / 100
        ppx = 1 / ((.Panes(1).PointsToScreenPixelsX(7200 / Z) - .Panes(1).PointsToScreenPixelsX(0)) / 7200)
        LpP = .ActivePane.PointsToScreenPixelsX(Target.Left) * ppx - 1.25
        TpP = .ActivePane.PointsToScreenPixelsY(Target.Top) * ppx
    End With
    With UserForm1
        .Show 0
        .Move LpP, TpP
    End With
End Sub
on ne verra pas vraiment la différence
demo.gif


sauf que moi le left et top c'est simplement le résultat de la fonction pointstoscreenpixels
et Nicolas utilise mon ancienne version de ppx le coeff diviseur et moui le multiplicateur
nicolas :1.333333333333333
moi:0.75
1 pixel / par 1.333....=0.75

Nicolas
VB:
 lleft = .PointsToScreenPixelsX(rng.Left * ppx * Zom) / ppx + bord
 ttop = .PointsToScreenPixelsY(rng.Top * ppx * Zom) / ppx

le mien
VB:
 LpP = .ActivePane.PointsToScreenPixelsX(Target.Left) * ppx - 1.25 '1.5
        TpP = .ActivePane.PointsToScreenPixelsY(Target.Top) * ppx
après tu peux débattre tant que tu veux les résultats sont là

tu parles de choses absurdes que tu entends
mais tu ne vois pas l'absurdité de cette formules
.PointsToScreenPixelsX(rng.Left * ppx * Zom) / ppx + bord

la fonction pointstoscreenpixels attend une dimension en point pas en pixel dans ces parenthèses
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
@Dudu2
En effet, toute référence à une propriété d'un UserForm (.Name, .Caption) ou même le simple fait le passer en argument d'une fonction a pour effet de le charger en mémoire et d'activer l'évènement UserForm_Initialize().
plus précisément de charger(INSTANCIER) un exemplaire de la classe du même nom
car le module userform est un module classe avant tout et donc son event initialize se déclenche
à ce moment là précisément l'object msforms.userform n'existe pas encore
 

patricktoulon

XLDnaute Barbatruc
re
ça y est je pige pourquoi

je l'avais sous les yeux 🤣 🤣

en fait Nicolas utilise
ActiveWindow.PointsToScreenPixels(Excel 2003)
moi j'utilise
ActiveWindow.ActivePane.PointsToScreenPixels (a partir de Excel 2007)

ou éventuellement
ActiveWindow.Panes(X).PointsToScreenPixels (a partir de Excel 2007)
'x étant l'index de la panes dans une feuille éventuellement fractionnée

ça veux dire que ta combine ne fonctionnera pas selon le fractionnement d'une feuille

je laisse @Dudu2 expliqué cela moi et lui avons très longuement travaillé dessus
 

Dudu2

XLDnaute Barbatruc
@patricktoulon,
En effet, il faut d'abord connaître le Pane de l'objet (cellule, forme, etc...) sur lequel on veut positionner le UserForm pour utiliser les Pan(x).PointsToScreenPixels.
On avait chacun sa version de cette recherche. La mienne étant:
VB:
'---------------------------------------------------
'Object Pane which Parent is the ActiveSheet
'- Visible = True: the Object must be visible
'- Visible = False: the Object can be visible or not
'---------------------------------------------------
Private Function ObjectPane(Object As Object, Optional Visible As Boolean = True) As Pane
    Dim Rng As Range
    Dim i As Integer
    Dim Pan As Pane
    Dim PosRow As Integer
    Dim PosColumn As Integer
 
    'The Object Parent is not then ActiveSheet
    If Not Object.Parent Is ActiveSheet Then Exit Function
   
    With ActiveWindow
   
       'Depending on the Object Type
       Select Case True
           Case TypeOf Object Is Range
               Set Rng = Object
   
           Case Else
               Set Rng = Object.TopLeftCell
       End Select
 
        '--------------------------------
        'The Object can be visible or not
        '--------------------------------
        If Not Visible Then
            If .SplitRow = 0 Then
                PosRow = 1
            Else
                If Rng.Row <= .SplitRow Then PosRow = 2 Else PosRow = 3
            End If
   
            If .SplitColumn = 0 Then
                PosColumn = 1
            Else
                If Rng.Column <= .SplitColumn Then PosColumn = 4 Else PosColumn = 5
            End If

            Select Case PosRow * PosColumn
                Case 1, 2, 4, 8
                    Set Pan = .Panes(1)
                Case 3, 5, 10
                    Set Pan = .Panes(2)
                Case 12
                    Set Pan = .Panes(3)
                Case 15
                    Set Pan = .Panes(4)
            End Select
 
        '--------------------------
        'The Object must be visible
        '--------------------------
        Else
            For i = 1 To .Panes.Count
                If Not Intersect(Rng, .Panes(i).VisibleRange) Is Nothing Then Exit For
            Next i
            If i <= .Panes.Count Then Set Pan = .Panes(i)
        End If
    End With
 
    'Return Value
    Set ObjectPane = Pan
End Function
 

Dudu2

XLDnaute Barbatruc
Je ne comprends pas pourquoi toutes ces prises de têtes pour réinventer la pomme de terre alors qu'encore une fois une (des ?) ressource existe pour faire ça qui inclut toutes ces question de marges, de Pane, etc...

Alors c'est vrai que la ressource ne fait que positionner. C'est sûr.
S'il faut aussi dimensionner, je peux ajouter les paramètres TargetWidth et TargetHeight.

Ou plus simplement rendre Public la fonction incluse GetUserFormMarginsPoints() pour que l'appelant l'utilise pour un dimensionnement sans les marges.
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
J'ai modifié la ressource pour pouvoir dimensionner le UserForm (avec ou sans ses marges selon un paramètre existant) à la taille de l'objet (Range en l'occurrence) désigné.
Nouveau paramètre optionnel: SizeOnWorksheetObject (True / False).
Ça devrait aussi fonctionner sur MAC mais là j'ai rien pour tester.
 

patricktoulon

XLDnaute Barbatruc
re
@Dudu2
On en avait discuté aussi de ça et j'avais conclu que pour moi l'API était la solution même si c'est plus lourd.
en fait c'est mon ancienne formule qui ne l'était pas

l'ancienne
VB:
With ActiveWindow.ActivePane
        PointToPixel = (.PointsToScreenPixelsY(72) - .PointsToScreenPixelsY(0)) / 72
    End With

la nouvelle
Code:
With ActiveWindow.Panes(1)
        ppx = 1 / ((.PointsToScreenPixelsY(7200*(.parent.zoom/100)) - .PointsToScreenPixelsY(0)) / 7200)
    End With
    MsgBox ppx
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
T'as fait une erreur, c'est plutôt:
VB:
    With ActiveWindow.Panes(1)
       ppx = 1 / ((.PointsToScreenPixelsY(7200 / (.Parent.Zoom / 100)) - .PointsToScreenPixelsY(0)) / 7200)
    End With

Mais bon si c'est plus précis que l'ancien calcul et finalement assez précis, ça reste chez moi pas 100% juste pour des valeurs non entières de zoom:
1711995840408.png

Code:
Sub a()
    Dim ppx As Double
    Dim Cell As Range
    Dim i As Integer
   
    Set Cell = [A1]
       
    With ActiveWindow.Panes(1)
        For i = 1 To 20
            .Parent.Zoom = 20 * i
            ppx = 1 / ((.PointsToScreenPixelsY(7200 / (.Parent.Zoom / 100)) - .PointsToScreenPixelsY(0)) / 7200)
            Cell.Value = .Parent.Zoom / 100
            Cell.Offset(, 1).Value = ppx
            Set Cell = Cell.Offset(1)
        Next i
        .Parent.Zoom = 100
        .Parent.ScrollRow = 1
        .Parent.ScrollColumn = 1
    End With
    'MsgBox Format(ppx, "#0.0000")
End Sub

En fait je pense que c'est le ZOOM qui n'est pas 100% ce qu'il dit être.
 

patricktoulon

XLDnaute Barbatruc
re
alors on profitera de l'arrondi du calcul qui ramène la 2d décimale à 5
en dpi 120 sur W7 ça devrait donner 0.6 soit le coeff diviseur de 1,66666666666667
VB:
Sub a()
    Dim ppx As Double
    Dim Cell As Range
    Dim i As Integer
    Dim Z As Double
    Set Cell = [A1]

    With ActiveWindow.Panes(1)
        For i = 20 To 400 Step 20
            .Parent.Zoom = i
            Z = .Parent.Zoom / 100
            ppx = Round(1 / ((.PointsToScreenPixelsY(7200 / Z) - .PointsToScreenPixelsY(0)) / 7200), 2)
            Cell.Value = .Parent.Zoom
            Cell.Offset(, 1).Value = ppx
            Set Cell = Cell.Offset(1)
        Next i
        .Parent.Zoom = 100
        .Parent.ScrollRow = 1
        .Parent.ScrollColumn = 1
    End With
    'MsgBox Format(ppx, "#0.0000")
End Sub
1711999980393.png


et si je simule le Dpi 120 soit 125
demo.gif


on est bon là non
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Chez moi ça reste inconstant:
1712000011086.png


Il y a bien une solution un peu bâtarde mais ça provoque une saute d'affichage, quelque soit le Application.ScreenUpdating.
VB:
Sub aa()
    MsgBox PixelToPoint
End Sub

Function PixelToPoint() As Double
    Dim ZoomAtCallTime As Integer
    Dim ScreenUpdatingAtCallTime As Boolean
    Dim pxpt As Double
    Dim k As Long
    
    With ActiveWindow
        k = Application.InchesToPoints(100)
        ZoomAtCallTime = .Zoom
        ScreenUpdatingAtCallTime = Application.ScreenUpdating
        Application.ScreenUpdating = False
        .Zoom = 100
        PixelToPoint = 1 / ((.Panes(1).PointsToScreenPixelsY(k / (.Zoom / 100)) - .Panes(1).PointsToScreenPixelsY(0)) / k)
        .Zoom = ZoomAtCallTime
        Application.ScreenUpdating = ScreenUpdatingAtCallTime
    End With
End Function
 

Dudu2

XLDnaute Barbatruc
Sinon, il y a toujours les solutions que tu avais trouvées:
Code:
#If VERSION = 1 Then
'----------------
'Version SANS API (100% exact, un Static pour éviter le Shell à chaque fois)
'----------------
Function PointToPixel() As Double
    Static SavePointToPixel As Double
  
    If SavePointToPixel = 0 Then
        SavePointToPixel = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1)
    End If
    PointToPixel = SavePointToPixel
End Function
#End If

#If VERSION = 2 Then
'----------------
'Version SANS API (100% exact, un Static car CPU augmente à chaque exécution d'ExecuteExcel4Macro())
'----------------
Function PointToPixel() As Double
    Dim DC As Long
    Static SavePointToPixel As Double
    
    If SavePointToPixel = 0 Then
        DC = ExecuteExcel4Macro("CALL(""user32"",""GetDC"",""JJJ"",0)")
        SavePointToPixel = ExecuteExcel4Macro("CALL(""gdi32"",""GetDeviceCaps"",""JJJ""," & DC & ", " & 88 & ")") / 72
    End If
    PointToPixel = SavePointToPixel
End Function
#End If
 

Discussions similaires

Statistiques des forums

Discussions
315 094
Messages
2 116 141
Membres
112 669
dernier inscrit
Guigui2502