XL 2016 Calculer la position sur l'écran d'une position sur la grille (XL 2003)

PHV.FSM

XLDnaute Nouveau
Dans le cadre de développement d'application, il y a des objets que l'on souhaite positionner par rapport à une cellule mais qui sont positionnés par rapport à l'écran et dont les coordonnées sont souvent exprimées en pixel. Par exemple les UserForms ou le curseur de la souris. J'ai cru que la solution était simple et j'ai trouvé des solutions sur le net qui s'avéraient au final très spécifiques à une configuration particulière et qui ne donnaient pas un résultat universel.

Voici le code préalable nécessaire pour utiliser la procédure principale : GetGridPos.
VB:
#If VBA7 Then
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
#Else
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
#End If

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X

'*** Public data initiated with 'GetScreenData'
Public PxToPt As Single    'Parameter to convert a step in pixel in point
Ainsi que le code suivant pour définir la taille du séparateur entre les panneaux :
VB:
'Pane Separator Size in Point
#If VBA7 Then
Private Const SEP_PIXSIZE = 3   '=>Estimé entre {2.7 & 3.3}
#Else
Private Const SEP_PIXSIZE = 6 '=>Estimé entre {5.7 & 6.3}
#End If
Private SeparatorSize As Long

Sub GetGridData()
    SeparatorSize = Round(SEP_PIXSIZE / PxToPt)
End Sub
Et enfin il faut inclure dans sa procédure d'initialisation le code suivant :
VB:
' In user's module 
Sub Init()
    '(...)
    Call GetScreenData: Call GetGridData
    Application.ActiveWindow.DisplayHeadings = False
    '(...)
End Sub

' In module 'ThisWorkbook' :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '(...)
    Application.ActiveWindow.DisplayHeadings = True
    '(...)
End Sub
Si vous utilisé la fonction GetGridPos avec l'indexe de panneau actif numéro 1, les entêtes d'affichage sont prisent en compte par les fonctions PointsToScreenPixelsX et PointsToScreenPixelsY mais sinon ce n'est pas le cas, la largeur de ces entêtes est variable, et je n'ai pas trouver de moyen d' interroger leur dimension.
Du coup, il est plus simple de ne pas afficher les entêtes ... (jusqu'à trouver un code alternatif).
Sauf exception, si vous n'utilisé pas de panneau.

Il est tout d'abord nécessaire de pouvoir convertir les grandeurs physiques exprimées en point, en pixel et cette valeur que je nomme PxToPt (Single) doit être calculé au travers une procédure d'initialisation 'GetScreenData'; contrairement à ce que j'avais lu sur une solution ou il s'agissait d'une valeur constante car cela change en fonction de l'écran ou de la résolution.
VB:
Sub GetScreenData()
Dim twipsPerPixelX As Long  '?? ...
Dim lngIC As Long
Dim lngRet As Long
    lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
    If lngIC <> 0 Then
        twipsPerPixelX = 1440 \ apiGetDeviceCaps(lngIC, LOGPIXELSX) 'Get the Screen X resolution
        apiDeleteDC (lngIC) 'Release the information context.
    Else    'Error : assume an average value.
        lngRet = MsgBox("Error..invalid Display Device Context..Exiting", vbOKOnly)
        Exit Sub
    End If
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
    ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
    PxToPt = (twipsPerPixelX / 20) 'Ratio convert twips to Pixel per Point
End Sub

Il existe la fonction suivante pour calculer la position sur l'écran d'une position ou grandeur sur la grille : Application.ActiveWindow.PointsToScreenPixelsX(x) ou PointsToScreenPixelsY(y)
x => Largeur ou abscisse
y => Hauteur ou ordonnée
Le problème c'est que cette fonction ne tient pas compte du zoom et que le calcul d'une largeur ou hauteur est approximatif dès que le zoom n'est pas à 100% dû au arrondis nécessaire pour passer d'une grandeur en point (valeur réelle) à une en pixel (valeur entière).
Voici la fonction pour calculer la distance entre deux rangées (Row ou Column) de la grille.
VB:
'(Use Running Constant PxToPt, ratio to convert point'size in pixel'size)
'Give pixel'size between two lines
Function GetGapSize(sht As Worksheet, startLine As Long, endLine As Long, isWidth As Boolean, zoomRatio As Single) As Long
Dim rgArea As Range, rgLine As Range
Dim lnPx As Single ' Long
    Set rgArea = sht.Range(Cells(IIf(isWidth, 1, startLine), IIf(isWidth, startLine, 1)), _
        Cells(IIf(isWidth, 1, startLine), IIf(isWidth, startLine, 1)))
    If isWidth Then Set rgArea = sht.Range(sht.Cells(1, startLine), sht.Cells(1, endLine)) Else _
        Set rgArea = sht.Range(sht.Cells(startLine, 1), sht.Cells(endLine, 1))
    If zoomRatio = 1 Then
        GetGapSize = IIf(isWidth, rgArea.Width, rgArea.Height) / PxToPt
    Else
        Set rgArea = IIf(isWidth, rgArea.Columns, rgArea.Rows)
        For Each rgLine In rgArea
            lnPx = IIf(isWidth, rgLine.Width, rgLine.Height)
            If lnPx > 0 Then
                lnPx = Round(lnPx * zoomRatio / PxToPt + 0.01)  '0.01 fix round pb with xx.5
                GetGapSize = GetGapSize + lnPx
            End If
        Next rgLine
    End If
End Function
Ensuite l'utilisation de panneaux complique énormément la calcul de la position :
J'utilise la fonction PointsToScreenPixels{X ou Y} avec 0 en paramètre qui me donne la position du panneau ACTIF !
Il faut ajouter :
  • Les rangées 'cachées' : ce sont les rangées situées entre la 1ère rangée et la rangée précédent la 1ère rangée visible dans le plan ACTIF.
Exemple avec le calcul d'une largeur : colonnes visible sur le plan actif H à M, la largeur sera celle allant de la colonne A à la colonne G.
  • Les rangées sur le plan ou la cellule se situe de la 1ère rangée visible à la rangée précédente de la cellule.
  • Les rangées visibles du plan actif si différent de celui de la cellule et si précédent celle-ci.
Voici les fonctions réalisant cela :
VB:
' Calcul the screen's coordinate of the top-left corner's cell
' cellTopLeft : grid's corner top-left point (CellTL)
' celPanIdx : Pane's index where CellTL is display
' Return : lXGrid, lYGrid position on screen (in Pixel)
Sub GetGridPos(ByRef lXGrid As Long, ByRef lYGrid As Long, cellTopLeft As Range, Optional celPanIdx As Integer = 1)
Dim sht As Worksheet    'Active Sheet in Active Workbook
Dim rgCrt As Range      'Current Area
Dim ratioZoom As Single 'Grid's ratio Zoom
'Pos Grid Var
Dim hideRows As Long, hideCols As Long  'Total of Hide Row and Column between Cells(1,1) and the beginning of the active's Area
Dim begRowAct As Long, endRowAct As Long, begColAct As Long, endColAct As Long  'Final active area's intervals
Dim begRowCel As Long, endRowCel As Long, begColCel As Long, endColCel As Long  'Final CellTL area's intervals
Dim rc1 As Long, rc2 As Long, cc1 As Long, cc2 As Long  'Row and Column interval of CellTL's Area between Start Area and Previous Cell's CellTL
Dim rz1 As Long, rz2 As Long, cz1 As Long, cz2 As Long  'Row and Column interval of Area(1) : (rz1,rz2) and (cz1,cz2)

Dim isOK As Boolean, isPanVert2 As Boolean, isPanHor2 As Boolean
Dim typPan As Integer   'Total Pane => 0 : 1, 1 : 2 Verticals, 2 : 2 Horizontals, 3 : 4
Dim actPanIdx As Integer   'Index of actif pane
    Set sht = ActiveWorkbook.ActiveSheet
    With Application
        With .ActiveWindow
            lXGrid = .PointsToScreenPixelsX(0)
            lYGrid = .PointsToScreenPixelsY(0)
            If (celPanIdx > 1) And Not (.FreezePanes) Then
                .SplitRow = .SplitRow: .SplitColumn = .SplitColumn  'Force separators position (between 2 range)
                isOK = True
            End If
            typPan = -(.SplitColumn > 0) - 2 * (.SplitRow > 0)
            isPanVert2 = ((celPanIdx - 1) And typPan) And 1 'True if Cell Pane is on right
            isPanHor2 = (celPanIdx - 1) And (typPan - 1)    'True if Cell Pane is on bottom
            If isOK Then    'Add pane's Sep width if panes are free
                If isPanVert2 Then lXGrid = lXGrid + SeparatorSize
                If isPanHor2 Then lYGrid = lYGrid + SeparatorSize
            End If
            ratioZoom = .Zoom / 100  'Theoretical zoom ratio
            Set rgCrt = .ActivePane.VisibleRange
            hideRows = rgCrt.Row - 1: hideCols = rgCrt.Column - 1   'Total hide line
            actPanIdx = .ActivePane.Index
            
            Set rgCrt = .Panes(celPanIdx).VisibleRange  'Get CellTL Intervals (rc1 to rc2, cc1 to cc2)
            rc1 = rgCrt.Row: rc2 = cellTopLeft.Row - 1: If rc1 > rc2 Then rc1 = 0
            cc1 = rgCrt.Column: cc2 = cellTopLeft.Column - 1: If cc1 > cc2 Then cc1 = 0
            Set rgCrt = .Panes(1).VisibleRange  'Get Pane(1) Intervals (rz1 to rz2, cz1 to cz2)
            If isPanHor2 Then
                rz1 = rgCrt.Row: rz2 = rz1 + rgCrt.Rows.Count - 1
            End If
            If isPanVert2 Then
                cz1 = rgCrt.Column: cz2 = cz1 + rgCrt.Columns.Count - 1
            End If
            
            If celPanIdx = actPanIdx Then   'if CellTL is on active pane
                begRowAct = rc1: begColAct = cc1: endRowAct = rc2: endColAct = cc2
                begRowCel = rz1: begColCel = cz1: endRowCel = rz2: endColCel = cz2
            Else
                If ((celPanIdx + 1) Xor (actPanIdx + 1)) Or typPan = 2 Then
                    begRowCel = rc1: endRowCel = rc2: begRowAct = rz1: endRowAct = rz2
                Else
                    begRowCel = rz1: endRowCel = rz2: begRowAct = rc1: endRowAct = rc2
                End If
                If (typPan And 1) And ((celPanIdx Xor actPanIdx) And 1) Then
                    begColCel = cc1: endColCel = cc2: begColAct = cz1: endColAct = cz2
                Else
                    begColCel = cz1: endColCel = cz2: begColAct = cc1: endColAct = cc2
                End If
            End If
            
            'Add the CellTL offset to coordinates
            lXGrid = lXGrid + CalCelOff(sht, True, ratioZoom, hideCols, begColCel, endColCel, begColAct, endColAct)
            lYGrid = lYGrid + CalCelOff(sht, False, ratioZoom, hideRows, begRowCel, endRowCel, begRowAct, endRowAct)
            
        End With
    End With
End Sub

'Calcul CellTL offset : interval's sum of the 'Hide Area'(ha), the 'CellTL Area' and the active Area
'st : the Active Sheet
'iW : true if is a width interval else is a height interval
'zR : ratio zoom of the active sheet
'ha : Total of Hide line(s) between Cells(1,1) and the beginning of the active Area
'c1, c2 : interval(c1,c2) of the 'CellTL' Area
'a1, a2 : interval(a1,a2) of the active Area
Private Function CalCelOff(st As Worksheet, iW As Boolean, zR As Single, ha As Long, c1 As Long, c2 As Long, a1 As Long, a2 As Long) As Long
Dim r As Long
    If ha = 0 Then
        If a1 > 0 Then
            If c1 > 0 Then CalCelOff = CalCelOff2(st, iW, zR, c1, c2, a1, a2) Else CalCelOff = GetGapSize(st, a1, a2, iW, zR)
        Else
            If c1 > 0 Then CalCelOff = GetGapSize(st, c1, c2, iW, zR)
        End If
    Else
        If a1 > 0 Then
            If ha = a1 - 1 Then a1 = 1 Else r = GetGapSize(st, 1, ha, iW, zR)
            If c1 > 0 Then CalCelOff = r + CalCelOff2(st, iW, zR, a1, a2, c1, c2) Else CalCelOff = r + GetGapSize(st, a1, a2, iW, zR)
        Else
            If c1 > 0 Then CalCelOff = CalCelOff2(st, iW, zR, 1, ha, c1, c2) Else CalCelOff = GetGapSize(st, 1, ha, iW, zR)
        End If
    End If
End Function

'Calcul 2 interval's sum
'st : the Active Sheet
'iW : true if is a width interval else is a height interval
'zR : ratio zoom of the active sheet
'(a,b) and (c,d) : intervals
Private Function CalCelOff2(st As Worksheet, iW As Boolean, zR As Single, a As Long, b As Long, c As Long, d As Long) As Long
Dim r As Long, e As Long, f As Long
    e = c
    If c < a Then
        f = d: c = a: d = b: a = e: b = f: e = c
    End If
    If c > b Then
        If b = c - 1 Then CalCelOff2 = GetGapSize(st, a, d, iW, zR) Else CalCelOff2 = GetGapSize(st, a, b, iW, zR) + GetGapSize(st, c, d, iW, zR)
    Else
        If c > a Then r = GetGapSize(st, a, c - 1, iW, zR)
        If b > d Then
            f = d: r = r + GetGapSize(st, d + 1, b, iW, zR)
        Else
            f = b: If d > b Then r = r + GetGapSize(st, b + 1, d, iW, zR)
        End If
        CalCelOff2 = r + 2 * GetGapSize(st, e, f, iW, zR)
    End If
End Function

Classeur avec un exemple d'utilisation proposée :
Pour pouvoir exploiter ou tester la procédure 'GetGridPos' j'ai pris le cas de l'utilisation d'un menu contextuel pour simuler une ListBox à partir de cellule réagissant à la sélection ce qui est plus facile à visualiser et tester.
Classeur 'ScreenPosListBox' testé sous excel 2003 et 2016 mais qui devrait fonctionner sur toutes les versions depuis office 2003.

Remarque : j'utilise la propriété ID des cellules sur lesquelles je simule un Listbox. Cette propriété est initialisée à l'ouverture du classeur et persiste durant toute la session sauf si on efface la cellule.
C'est pour cela que j'ai ajouté une protection empêchant l'effacement de la propriété.
 

Pièces jointes

  • ScreenPosListBox2016.xlsm
    47 KB · Affichages: 23
  • ScreenPosListBox2003.xls
    124 KB · Affichages: 19
Dernière édition:

PHV.FSM

XLDnaute Nouveau
re
je reviens un peu sur ton raisonnement

alors oui chez toi ca fonctionne
mais chez moi par exemple ou je suis en 1600X900
ca donne 0.75X1600=1200
donc si je reprends ta formule du post 14
VB:
Sub test()
With ActiveWindow
   PxToPt = Round(1200 / ((.Panes(1).PointsToScreenPixelsX(7200 / .Zoom)) - .Panes(1).PointsToScreenPixelsX(0))) / 20
End With
Debug.Print "PxToPt=" & PxToPt & " & PtToPx=" & 1 / PxToPt
End Sub

j'obtiens le coefficient 125% alors que je suis en 100%
PxToPt=0,6 & PtToPx=1,66666666666667
Si j'ai compris tu veux afficher un UserForm et tu dois convertir la position en pixel, en point.
Il serait plus simple de partager tout ton code pour comprendre ton problème car c'est peut-être un autre problème que tu as ?
 

TooFatBoy

XLDnaute Barbatruc
alors oui chez toi ca fonctionne
mais chez moi par exemple ou je suis en 1600X900
ca donne 0.75X1600=1200

donc si je reprends ta formule du post 14
j'obtiens le coefficient 125% alors que je suis en 100%
Pourtant tu sembles bien être à 125 % (tu l'as d'ailleurs entouré en bleu).
1692096183093.png


Me trompé-je ? 🤔
 
Dernière édition:

PHV.FSM

XLDnaute Nouveau
re oui c'est bien ce que je pensais c'est pas bon même sur W10
ta formule ne prend pas en compte le DPI
VB:
Sub test2()
    Dim R As Range, p As Pane, Position As Variant
    Set R = [C3]
    Set p = ActiveWindow.Panes(1)
    Position = TopLeftCellule(p, R, True)
    With UserForm1
        .startupposition = 0
        .Show 0
        .Left = Position(1)
        .Top = Position(2)
       
    End With
End Sub

Public Function TopLeftCellule(ByVal LePane As Pane, ByVal Rng As Range, Optional ByVal DansLaCellule As Boolean = True)
    Dim L As Integer, T As Integer, PtoPx#
    Dim totIt As Long
    With LePane
        'PtoPx = Round(1440 / ((.PointsToScreenPixelsX(7200 / .Parent.Zoom)) - .PointsToScreenPixelsX(0))) / 20
         PtoPx = ((.Parent.Panes(1).PointsToScreenPixelsX(72 / (.Parent.Zoom / 100))) - .Parent.Panes(1).PointsToScreenPixelsX(0)) / 72
      L = .PointsToScreenPixelsX(Rng.Left) / PtoPx
        T = .PointsToScreenPixelsY(Rng.Top) / PtoPx
    End With
    TopLeftCellule = Array(PtoPx, IIf(DansLaCellule, L, L - 1), IIf(DansLaCellule, T, T - 1))
End Function
reglage dpi 120

Regarde la pièce jointe 1176484

test avec ta formule
normalement le userform est sensé aller sur [C3]

Regarde la pièce jointe 1176487

maintenant test avec ma formule
et toujours pareil le userform est sensé aller en [C3]
Regarde la pièce jointe 1176488

voila comme quoi quand c'est trop beau ben .... c'est trop beau
conclusion ta formule est inutile car elle ne prend pas en compte le dpi
j'aurais le même résultat en faisant ptopx=4/3 😅 😅 😅 🥳

elle ne fonctionnera qu'en zoom W10 à 100%

tu peux donc jeter cette formule
voila voila ;)
Merci pour le 'ta' formule, je pensais que c'était un travail collaboratif :
Ma variable était PxToPt = 1 / Ptopx
Voici le code correspondant :
VB:
Public Function TopLeftCellule(ByVal LePane As Pane, ByVal Rng As Range, Optional ByVal DansLaCellule As Boolean = True)
    Dim L As Integer, T As Integer, PxToPt#
    Dim totIt As Long
    With LePane
        PxToPt = Round(1440 / ((.PointsToScreenPixelsX(7200 / .Parent.Zoom)) - .PointsToScreenPixelsX(0))) / 20
         'PtToPx = ((.Parent.Panes(1).PointsToScreenPixelsX(72 / (.Parent.Zoom / 100))) - .Parent.Panes(1).PointsToScreenPixelsX(0)) / 72
        L = .PointsToScreenPixelsX(Rng.Left) * PxToPt
        T = .PointsToScreenPixelsY(Rng.Top) * PxToPt
    End With
    TopLeftCellule = Array(PxToPt, IIf(DansLaCellule, L, L - 1), IIf(DansLaCellule, T, T - 1))
End Function
Dans ta formule tu utilses Panes(1) alors que la cellule appartient à 'LePane', qui n'est pas forcément Panes(1).
Manque de rigueur tu ne crois pas ?
 

PHV.FSM

XLDnaute Nouveau
re
ben non justement
la formule ptpx ne doit utiliser que le panes(1)(sur W7)
je pensais que tu connaissait le truc sur W7
et que la cellule par exemple la [d3] de la panes(2 ou 3 ou 4) n'est pas a la même distance que celle de la panes(1)
il suffit de regarder ton écran pour s'en rendre compte 😅😅
Regarde la pièce jointe 1176626
alors oui sur w 10 ca n'a plus d'importance mais sur w 7 oui
donc pour faire un code générique W10 et 7 j'utilise le panes(1) strictement pour le calcul ptpx

ce n'est absolument pas un manque de rigueur
ça fait suffisamment de temps que je pratique le truc sur w7 pour savoir ;)
et je découvre et analyse les divergences sur W10

par contre le manque de rigueur c'est de croire que sur W7 une donnée en dur comme 1440 dans le calcul
va être bon dans toute les config et résolution graphique

le manque de rigueur aussi est de croire que activepane va te donner la pane active à tout les coups
sachant que (je te le dis au cas ou tu ne le sais pas dans un freezepane activepane te donnera la première dispo à droite et en bas
je te fait un classeur demo si tu veux et si tu a W7

après je le redis visiblement sur W10 tout ce calcul est inutile
on ferait ptpx=4/3 ou ptpx=1*0.75 serait amplement suffisant

un pixel sera toujours un pixel il est indivisible et =0.75 points soit 1point = 1.333333333333333 pixel
c'est le coefficient d'affichage qui varie en fonction du paramétrage graphique
VersWin.jpg

Je travaille sur Windows 7 et je peux aussi faire des tests sur d'autre version mais cela n'a pas d'intérêt je crois.
VB:
Sub aff(noPane As Integer)
Dim PxToPt As Single
    With ActiveWindow
        PxToPt = Round(1440 / (.Panes(noPane).PointsToScreenPixelsX(7200 / .Zoom) - .Panes(noPane).PointsToScreenPixelsX(0))) / 20
    End With
    Debug.Print "Pane no=" & noPane & ", PxToPt=" & PxToPt; ", " & "PtoPx=" & 1 / PxToPt
End Sub

Sub FourPaneTest()
Dim cnt As Integer
    With ActiveWindow
        For cnt = 1 To .Panes.Count
            Call aff(cnt)
        Next cnt
    End With
End Sub
Résultats chez moi :
Pane no=1, PxToPt=0,75, PtoPx=1,333333
Pane no=2, PxToPt=0,75, PtoPx=1,333333
Pane no=3, PxToPt=0,75, PtoPx=1,333333
Pane no=4, PxToPt=0,75, PtoPx=1,333333
Il suffit de travailler toujours avec le même Pane 1, 2, 3 ou 4 ...
 

TooFatBoy

XLDnaute Barbatruc
un pixel sera toujours un pixel il est indivisible et =0.75 points soit 1point = 1.333333333333333 pixel
c'est le coefficient d'affichage qui varie en fonction du paramétrage graphique
Est-ce que ce n'est pas ce dont on parlait dans un autre fil où j'obtenais une valeur que tu trouvais bizarre et tu devais modifier la formule pour prendre en compte cette valeur ???
 

PHV.FSM

XLDnaute Nouveau
Moi non plus je ne tolère pas cela mais désolé c'est très sérieux !
Tu es le seul à avoir des problèmes de version Windows, de zoom windows et pourquoi pas des anomalies durant la pleine lune.
T'inquiète je ne vais plus perdre de temps à te répondre ...
 

PHV.FSM

XLDnaute Nouveau
[HS]


Pourquoi ne passes-tu pas sous cette daube de W10 (voire 11, si c'est aussi gratuit) ?

Bon, il y a peut-être bien la réponse dans la question... mais tout de même : tell me why ???

[/HS]
Pour l'instant j'ai pas envie de réinstaller et cette version me convient. Puis si windows 10 est une daube ... J'utilise windows 10 sur mon ordi portable. Voilà tout.
 

PHV.FSM

XLDnaute Nouveau
[HS] Positionner un UserForm sur la grille pour une version Excel 2007 ou ultérieure

Voici une solution simple qui ne gère pas les données mal calibrées :
VB:
Public PxToPt#

Sub SetPosUserFormOnGrid(objUF As Object, target As Range, Optional noPane As Integer = 1)
    Set pn = ActiveWindow.Panes(noPane)
    objUF.Left = pn.PointsToScreenPixelsX(target.Left) * PxToPt
    objUF.Top = pn.PointsToScreenPixelsY(target.Top) * PxToPt
End Sub

Sub GetRatio_PxToPt()
Dim crtZoom#, adrFirstCell As String
    With ActiveWindow
        adrFirstCell = .ActiveSheet.ScrollArea
        .ActiveSheet.ScrollArea = .Panes(1).VisibleRange.Cells(1).Address
        crtZoom = .Zoom: .Zoom = 100
        PxToPt = 72 / (.Panes(1).PointsToScreenPixelsX(72) - .Panes(1).PointsToScreenPixelsX(0))
        .Zoom = crtZoom: .ActiveSheet.ScrollArea = adrFirstCell
    End With
End Sub

'Ajouter un UserForm à votre classeur (UserForm1 : nom par défaut)
'A adapter bien-sûr
Sub TestPosUserForm1()
    GetRatio_PxToPt 'Variable du module à calculer au préalable
    UserForm1.Show False    'Il faut afficher le UserForm avant de pouvoir le positionner
    SetPosUserFormOnGrid UserForm1, Range("WPW1046214")
    'SetPosUserFormOnGrid UserForm1, Range("AE1046212"), 2
    'SetPosUserFormOnGrid UserForm1, Range("WPX346"), 3
    'SetPosUserFormOnGrid UserForm1, Range("AG340"), 4
End Sub
 

Lu76Fer

XLDnaute Occasionnel
Il y a un petit soucis dans le calcul du ratio : GetRatio_PxToPt, il faut utiliser ActivePane plutôt que Panes(1) car sinon il y a un scrolling qui peut se produire dans le test, voici la version corrigée dans laquelle il suffit de préciser sur quel volet on travaille :
SetPosUserFormOnGrid UserForm1, rg, 1 '1 étant le volet à changer pour tester

VB:
Public PxToPt#

Sub SetPosUserFormOnGrid(objUF As Object, target As Range, Optional noPane As Integer = 1)
    Set pn = ActiveWindow.Panes(noPane)
    objUF.Left = pn.PointsToScreenPixelsX(target.Left) * PxToPt
    objUF.Top = pn.PointsToScreenPixelsY(target.Top) * PxToPt
End Sub

Sub GetRatio_PxToPt()
Dim crtZoom#, adrFirstCell As String, actCel As Range
    With ActiveWindow
        Set actCel = ActiveCell: adrFirstCell = .ActiveSheet.ScrollArea
        .ActiveSheet.ScrollArea = .ActivePane.VisibleRange.Cells(1).Address
        crtZoom = .Zoom: .Zoom = 100
        PxToPt = 72 / (.Panes(1).PointsToScreenPixelsX(72) - .Panes(1).PointsToScreenPixelsX(0))
        .Zoom = crtZoom: .ActiveSheet.ScrollArea = adrFirstCell: actCel.Activate
    End With
End Sub

'Ajouter un UserForm à votre classeur (UserForm1 : nom par défaut)
'A adapter bien-sûr
Sub TestPosUserForm1()
Dim rg As Range
    Set rg = ActiveCell: Debug.Print rg.Address
    GetRatio_PxToPt 'Variable du module à calculer au préalable
    UserForm1.Show False    'Il faut afficher le UserForm avant de pouvoir le positionner
    SetPosUserFormOnGrid UserForm1, rg, 1   'Il faut préciser le volet sur lequel on travail
    'SetPosUserFormOnGrid UserForm1, Range("WPW1046214")
    'SetPosUserFormOnGrid UserForm1, Range("AE1046212"), 2
    'SetPosUserFormOnGrid UserForm1, Range("WPX346"), 3
    'SetPosUserFormOnGrid UserForm1, Range("AG340"), 4
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
313 283
Messages
2 096 811
Membres
106 751
dernier inscrit
Souleymani