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
Bonjour
et surtout si notre amis avait un peu plus cherché il aurait trouvé plus simple pour le positionnement sur une cellule ou un object sur n'importe quelle panne dans une feuille en pixel ou en points
faut il encore chercher ;)
Coucou Patrick !
Exact ! utilisant la version d'Excel 2003, je n'avais pas la fonction PointsToScreenPixelsX ou Y pour l'objet Pane mais uniquement pour l'objet Window. Je me suis rendu compte qu'à partir de la version Excel 2007 la fonction de l'objet Pane répond parfaitement à ce problème.
Cependant, le code ci-dessus est utile pour la version 2003 et s'il y a plus simple je suis preneur.

Voici la solution pour les versions 2007 et supérieur :
VB:
Public Function TopLeftCellule(ByVal LePane As Pane, ByVal Rng As Range, Optional ByVal DansLaCellule As Boolean = True) As Position
Dim L As Integer, T As Integer
Dim totIt As Long
    With LePane
        L = .PointsToScreenPixelsX(Rng.Left)
        T = .PointsToScreenPixelsY(Rng.Top)
    End With
    TopLeftCellule.Left = IIf(DansLaCellule, L, L - 1)
    TopLeftCellule.Top = IIf(DansLaCellule, T, T - 1)
End Function
J'avais vu les échanges avec un Paria et toute la suffisance de ces réponses, du coup j'ai répondu à leur contribution de l'époque ;)
https:,,www.developpez.net,forums,d1733948,logiciels,microsoft-office,excel,contribuez,determiner-coordonnees-pixels-rapport-l-ecran-coin-superieur-gauche-d-cellule-excel,#post11965499
Je t'invite à jeter un coup d'oeil ;)
 

PHV.FSM

XLDnaute Nouveau
je suis allé un peu vite avec le zoom
la bonne formulation c'est ça
VB:
Sub test()
    Dim R As Range, p As Pane
    Set R = [C3]
    Set p = ActiveWindow.Panes(1)
    Position = TopLeftCellule(p, R, True)
    MsgBox " la cellule " & R.Address(0, 0) & " se trouve en position " & Position(1) & " points de left et " & Position(2) & " points de top " & vbCrLf & _
           "le coefficient points to pixel est :" & Position(0)
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 = ((.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
Pourrais-tu tester la procédure suivante avec ta fonction et me dire si le curseur de la souris se positionne correctement :
VB:
#If VBA7 Then
    Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
#Else
    Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
#End If

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)

    SetCursorPos Position(1), Position(2)
End Sub
Peux-tu aussi me dire sur quelle version d'Excel tu travailles ?
Merci d'avance
 

PHV.FSM

XLDnaute Nouveau
Oui je suis d'accord, je ne comprenais pas le calcul de ptopx. Ce n'est pas utile de calculer ceci dans mon cas.
J'aurai voulu savoir si cela fonctionne bien aussi sur la version Excel 2007.
Je vais devoir installer une version pour voir ...
 

PHV.FSM

XLDnaute Nouveau
J'ai installé Excel 2007 et cela fonctionne très bien aussi, on peut donc conclure que la fonction
pane.pointstoscreenpixel(X ou Y) fonctionne parfaitement et existe depuis Excel 2007.
Je vais donc reprendre mon 1er message pour que ce soit plus claire (béquille pour la version 2003 uniquement).
 

PHV.FSM

XLDnaute Nouveau
a ben non!!!! voyons
topleftcellule te renvoie les positions en points set cursorpos c'est pixel
il te faut enlever la division
comme ca oui

VB:
#If VBA7 Then
    Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
#Else
    Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
#End If

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)

    SetCursorPos Position(1), Position(2)
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 = ((.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
Oui je t'ai répondu plus haut mais sans reprendre ta conversation :rolleyes:
Le calcul de PtoPx est très intéressant et très bien optimisé mais il ne fonctionne pas avec certaine valeur de zoom :
Avec 1,34722222222222 avec Zoom à 190% au lieu de 1,3333333333
J'avais développé une autre solution pour déterminé l'inverse de ce coefficient mais c'est moins optimisé (une quinzaine de ligne). Cependant, j'ai remarqué que le coefficient que l'on obtient a comme dernière décimale un 0 ou un 5.
Du coup, en reprenant ton code j'ai inversé la formule, diviser par 5 et multiplier par 100 en arrondissant le résultat à une valeur entière. Puis je redivise par 20 (100/5).
Voici à partir de ton code la nouvelle formule que je te propose :
VB:
With ActiveWindow
   PxToPt = Round(1440 / ((.Panes(1).PointsToScreenPixelsX(7200 / .Zoom)) - .Panes(1).PointsToScreenPixelsX(0))) / 20
End With
Debug.Print "PxToPt=" & PxToPt & " & PtToPx=" & 1 / PxToPt
 

PHV.FSM

XLDnaute Nouveau
re
pas mal du tout
il faudra tester en DPI 120 soit 125% sur W7
sur W10 le zoom est différent donc on peut pas verifier mais bon ca colle pour l'instant
VB:
Sub test()

    With ActiveWindow
        .Zoom = 50
        For i = 50 To 400 Step 10
            .Zoom = i
            DoEvents
            PxToPt = Round(1440 / ((.Panes(1).PointsToScreenPixelsX(7200 / .Zoom)) - .Panes(1).PointsToScreenPixelsX(0))) / 20
            Debug.Print "zoom " & .Zoom & " " & "PxToPt=" & PxToPt & " & PtToPx=" & 1 / PxToPt
        Next
      .Zoom = 100
 End With
 End Sub
Sinon le calcul est bon en faite car c'est une façon maline de demander à Excel le facteur PxToPt qu'il utilise mais le problème c'est qu'un zoom différent de 100% nécessite des approximations ou arrondis qui se cumulent sur plusieurs colonnes.
Ex : ptToPx = 1.333333
Largeur de 5 colonnes de 6 points à 100% : 6*1.33333 * 5 = 8 * 5 = 40 pixels (cela tombe toujours rond)
Avec un zoom à 190% : 40 * 1.9 = 76 pixels
Mais pour chaque colonne : 6*1.33333*1.9=15.2 pixels => Arrondi à 15 pixels
soit 15*5 = 75 pixels
D'ou une erreur de 1 pixel dans cet exemple.

C'est mon interprétation et celle qui m'a permis de faire les calculs avec arrondi pour Excel 2003, et qui fonctionne.

Du coup inutile de faire un arrondi, je pense il suffit de reprendre ta formule en enlevant le zoom en fixant le zoom à 100% avant de faire le calcul puis de le rétablir. Encore plus simple et propre !
 

PHV.FSM

XLDnaute Nouveau
Pour revenir sur le sujet du post voici une autre méthode de calcul de PxToPt pour Excel 2003 qui n'utilise pas de d'appel à des fonctions système :
VB:
Function GetRatio_PxToPt(wtTarget As Worksheet) As Single
Dim rh As Single
Dim dMem As Single
Dim pxSz As Single
Dim dTmp As Single
Dim isHide As Boolean
Dim bUS As Boolean
    bUS = Application.ScreenUpdating: If bUS Then Application.ScreenUpdating = False
    With wtTarget.Rows(1)
        If .Hidden Then
            isHide = True: .Hidden = False
        End If
        dMem = wtTarget.Rows(1).RowHeight: pxSz = 0: rh = 0
        While pxSz = 0
            rh = rh + 1: .RowHeight = rh: pxSz = wtTarget.Rows(2).Top
        Wend
        rh = pxSz: dTmp = pxSz
        Do
            pxSz = dTmp: rh = rh - 0.1: .RowHeight = rh
            dTmp = wtTarget.Rows(2).Top
        Loop Until dTmp = 0
        .RowHeight = dMem
        If isHide Then .Hidden = True
    End With
    If bUS Then Application.ScreenUpdating = True
    GetRatio_PxToPt = pxSz
End Function
 

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 ;)
J'avais tester le zoom de windows et cela n'interfèrait pas dans le calcul de de PxToPt ou ptopx.
Ce coefficient permet de passer d'un taille (distance) en un nombre de pixel.
Le fait de changer le zoom de Windows chez moi ne change pas la résolution de mon écran qui d'ailleurs est optimisé pour cette résolution.
J'ai 1920 pixels en largeur ce qui correspond à 0.75 * 1920 = 1440 points.
Le fait de changer le zoom de windows ne changeant pas la largeur de mon écran, ni sa résolution le coefficient PxToPt ne doit donc pas changer car il y a toujours le même nombre de pixel / point ou de pixel / pouce ou de pixel / cm ...
 

TooFatBoy

XLDnaute Barbatruc
même la clé de registre sur W10 donne 96 soit dpi 100% quand je suis en zoom 125% Windows
Attention je parle bien du zoom windows pas le zoom excel hein entendons nous bien !!
VB:
Sub test5()
 With CreateObject("WScript.Shell"): DPI_Regedit = .RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI"): End With
   MsgBox DPI_Regedit
End Sub
ce qui veux dire qu'il nous reste plus que ma formule qui fonctionne même si elle est pas tout a fait précise
encore une cochonnerie de wwindows 10( il les accumule celui là )
et sur windows11 c'est pire 😅 😅
Toi qui bosses sur le sujet depuis des années, aurais-tu des liens à me conseiller vers des pages donnant toutes les possibilités d'obtenir (par API, Shell, fonction Excel, BdR Windows, ou autres) des informations sur :
- les écrans connectés au PC,
- le zoom du Bureau,
- le zoom d'Excel,
- etc.
?
 
Dernière édition:

Discussions similaires

Statistiques des forums

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