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

patricktoulon · 1 Avril 2024

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

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

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

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

patricktoulon · 1 Avril 2024

re
tenez dites moi que les calculs sont faux

patricktoulon · 1 Avril 2024

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 · 1 Avril 2024

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 · 1 Avril 2024

@patricktoulon,

tenez dites moi que les calculs sont faux

C'est surtout en-dessous de 100 que les valeurs de ppx ne sont pas 100% précises. Certes proches mais pas exactes. 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.

Dudu2 · 1 Avril 2024

@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 · 1 Avril 2024

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...

VBA - Positionner un UserForm sur un Objet d'une Feuille (Cellule, Contrôle, Forme, Image, etc...)

Le fichier à télécharger contient: Le Module_PositionUserFormOnSheetO à importer dans le projet VBA. Le Module_Test comme exemple de mise en œuvre. Note: Voir toutes mes ressources -> https://excel-downloads.com/resources/?creator_id=268468...

excel-downloads.com

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.

Dudu2 · 1 Avril 2024

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 · 1 Avril 2024

re

patricktoulon · 1 Avril 2024

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

Dudu2 · 1 Avril 2024

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:

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 · 1 Avril 2024

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

et si je simule le Dpi 120 soit 125

on est bon là non

Dudu2 · 1 Avril 2024

Chez moi ça reste inconstant:

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 · 1 Avril 2024

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

patricktoulon · 1 Avril 2024

re
c'est étonnant non tu trouve pas
que chez moi

ou il y a le boxon dans mes drivers
ou j'ai rien compris a calcul dpi
etc..

j'arrive a des calculs constants

oui des solutions j'en ai trouvé quelque unes
je les avais oubliés celles là

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

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Partager cette page

Statistiques des forums