XL 2016 Démo pour positionner un UserForm ou ContextMenu sur la grille (Toute version)

[Lu76Fer]

P.J. :

• GetScreenPosDemo.xlsm : la démo
• GetScreenPosDemo.xls : la conversion pour Excel 2003

Cette démo permet de montrez comment positionner un UserForm ou un Menu Contextuel sur une position de la grille
La fonction permettant de convertir une position de la grille en position écran et toutes les fonctions associées sont contenues dans le module 'Lib' et les fonctions assurant la compatibilité avec Excel 2003 dans le module 'LibV11'
Avec ce problème, c'est l'occasion de montrer comment assurer la compatibilité avec toutes les versions depuis 2003 avec la constante de précompilation classique VBA7 mais qui ne répond pas au problème du passage de la version 2003 à 2007. Dans ce cas il faut utiliser du simple code :

XLS2003 = IIf(Val(Application.Version) < 12, True, False)

La fonction permettant d'obtenir la position écran à partir du coin Haut-Gauche d'une cellule est GetScreenGridPos et GetScreenGridPosV11 pour la version Excel 2003.
Remarque : pour plus de détails sur la version XLS 2003 voir le sujet "Calculer la position sur l'écran d'une position sur la grille (XL 2003)" sur le Forum d'"excel-downloads.com"

Les fonctions pane.PointsToScreenPixelsX et pane.PointsToScreenPixelsY d'Excel assure déjà plutôt bien cette fonction (disponible depuis la version Excel 2007) mais comporte une imprécision variant de 1 (zoom à 100%) à 4 (zoom à 400%) pixels qui est corrigé par cette fonction reprenant le principe de l'algorithme développé par Pijaku en éliminant les 2 à 3% de cas d'echec de sa fonction et en améliorant la performance.
Source : voir le sujet "Déterminer les coordonnées en pixels, par rapport à l'écran, du coin supérieur gauche d'une cellule Excel" sur le forum du site "www.developpez.net"
Ce que j'ai corrigé ce sont les cas ou la position déterminée au départ est située en dehors de la grille et qui concerne les cellules du pourtour de la grille. Pour retrouver la grille je me déplace en diagonale en direction de la grille plutôt que de façon rectiligne. Une fois la grille trouvée je cherche le coin de la cellule en me déplaçant de façon rectiligne.

Public Function GetScreenGridPos(ByVal noPane As Integer, ByVal cellTopLeft As Range) As ScreenPos
Dim cel As Range, x As Long, y As Long, crtPane As Pane
Dim wayHor As Integer, wayVert As Integer, state As Byte, totIt As Byte
    Set crtPane = ActiveWindow.Panes(noPane)
    With crtPane
        'Repérer la 1ère ligne et la 1ère colonne du volet
        wayHor = IIf(cellTopLeft.Column = .ScrollColumn, 1, -1)   'Sens Hor
        wayVert = IIf(cellTopLeft.row = .ScrollRow, 1, -1)    'Sens Vert
        x = .PointsToScreenPixelsX(cellTopLeft.Left)
        y = .PointsToScreenPixelsY(cellTopLeft.Top)
        Do
            Set cel = ActiveWindow.RangeFromPoint(x, y)
            If cel Is Nothing Then
                If (state And 2) Then state = state + 2
                x = x + wayHor: y = y + wayVert
            Else
                If state < 3 Then
                    If cel.Left < cellTopLeft.Left Then
                        state = IIf(state = 2, 4, 1)
                        x = x + 1
                    Else
                        Select Case state
                        Case 0: wayHor = 1: wayVert = 0: state = 2
                        Case 1: state = 4
                        Case 2: x = x - 1
                        End Select
                    End If
                End If
                If state > 3 Then
                    If cel.Top < cellTopLeft.Top Then
                        state = IIf(state = 6, 8, 5)
                        y = y + 1
                    Else
                        Select Case state
                        Case 4: wayHor = 0: wayVert = 1: state = 6
                        Case 5: state = 8
                        Case 6: y = y - 1
                        End Select
                    End If
                End If
            End If
            totIt = totIt + 1: If totIt = 20 Then state = 9
        Loop Until state > 7
    End With
    'State = 9 : retour=(0,0)
    GetScreenGridPos.x = IIf(state = 8, x, 0)
    GetScreenGridPos.y = IIf(state = 8, y, 0)
End Function

Le deuxième élément important à calculer est le coefficient permettant de passer d'une grandeur en pixel vers une grandeur en point :
J'ai créer une variable globale 'PxToPt' que je calcule au moment de l'initialisation.
Il existe plusieurs façon de calculer ce coefficient, dont une qui utilise des fonctions systèmes et permet aussi de connaître la résolution de l'écran.
Cf la fonction 'GetScreenData' sur le sujet "Calculer la position sur l'écran d'une position sur la grille (XL 2003)" sur le Forum d'"excel-downloads.com".
Sinon il existe ce calcul très simple que j'ai testé avec toute les valeurs entières de zoom entre 10 et 400 et fonctionne très bien :

Sub SetPxToPt()
    With ActiveWindow
        PxToPt = Round(11520 / (.Panes(1).PointsToScreenPixelsX(57600 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))) / 20
    End With
End Sub

Cette macro ne peut être utilisée sous Excel 2003 car pane.PointsToScreenPixelsXouY n'existait pas et il y a donc la macro 'SetPxToPtV11' qui détermine le taux par tatonnement. Elle cherche la plus petite hauteur d'une ligne (1 pixel) et interroge excel pour savoir quel est cette hauteur en point.

Les modules 'exemple' permettant de tester les fonctions ci-dessus
Le module 'Ex1' : il met à disposition un menu contextuel qui permet de changer le nombre de volet, le zoom, de changer d'algo pour tester GetScreenGridPos et GetScreenGridPosV11 ...
Le module 'Ex2' :
Il est possible d'afficher le Userform1 depuis le menu contextuel mais dans certaines versions Excel (ou windows), l'affichage du menu contextuel déborde un peu par rapport à la position d'affichage.
La fonction 'SwapWindowStyle', utilisant des fonctions système permet de modifier l'apparence du Userform en le transformant en simple rectangle, est une solution au problème ci-dessus. Accessible depuis le menu avec le bouton 'Basculer en Style Simple'.

Retirer la compatibilité avec Excel 2003 :

• Il faut supprimer le module 'LibV11'
• Dans le module 'Lib' :

Il faut modifier la macro 'InitLib' en remplaçant

Call InitLibV11

par

SetPxToPt

Il faut retirer, dans la fonction 'GetScreenGridPos', la partie en commentaire 'COMP2003'
La fonction 'GetGapSize' n'a pas forcément d'utilité sauf cas particulier et peut être retiré aussi

 

[Lu76Fer]

Chez moi, les calculs en fonction du Zoom sont plus précis en partant du PixelToPoint de la fonction de @Lu76Fer du Post #40.
Le fait de partir sur un PointToPixel donne des résultats variables sur la 3ème voire 2ème décimale en fonction du Zoom (chez moi et je sais PAS chez toi en mémoire de vieux tests).
Regarde la pièce jointe 1180794
Ça vaut évidemment pour des conversions PixelToPoint de type 0.6 ou 0.75. Je ne sais pas s'il existe des conversions PixelToPoint dont les décimales sont plus nombreuses.

C'est par ce que j'avais observer que PxToPt peut-être arrondi en un multiple de 5 (d'ou la division par 20 dans ma formule) sur la 2ème décimale (0.60 & 0.75) que je suis parti sur le ratio inverse 1/0.60 = 1.6666666. Du coup plus facile de tomber juste ... Cela dit il faut que mon observation soit vérifiée.

 

[patricktoulon]

re
non le coeff c'est bien 0.75 pour un dpi de 100% et 0.6 pour un dpi 125%
1.333333333333333 ca c'est immuable pour un dpi de 100%
1/1.333333333333333=0.75
te reste plus qu'a multiplier par ton dpi/100

Sub test()
    K1 = 72000
    With ActiveWindow.Panes(1)
        For i = 50 To 400 Step 10
          a = a + 1
          .Parent.Zoom = i
            ZoomRatio = .Parent.Zoom / 100
            PointToPixel = (.PointsToScreenPixelsX(K1 / ZoomRatio) - .PointsToScreenPixelsX(0)) / K1
            Cells(a, 1) = i
            Cells(a, 2) = PointToPixel
        Next
        .Parent.Zoom = 100
        [A1].Select
    End With
End Sub

mes résultats 15 décimales

50​	1,333333333333330​
60​	1,333333333333330​
70​	1,333333333333330​
80​	1,333333333333330​
90​	1,333333333333330​
100​	1,333333333333330​
110​	1,333333333333330​
120​	1,333333333333330​
130​	1,333347222222220​
140​	1,333347222222220​
150​	1,333333333333330​
160​	1,333333333333330​
170​	1,333347222222220​
180​	1,333319444444440​
190​	1,333347222222220​
200​	1,333333333333330​
210​	1,333361111111110​
220​	1,333319444444440​
230​	1,333333333333330​
240​	1,333333333333330​
250​	1,333333333333330​
260​	1,333333333333330​
270​	1,333347222222220​
280​	1,333305555555560​
290​	1,333361111111110​
300​	1,333333333333330​
310​	1,333347222222220​
320​	1,333333333333330​
330​	1,333333333333330​
340​	1,333319444444440​
350​	1,333305555555560​
360​	1,333347222222220​
370​	1,333291666666670​
380​	1,333319444444440​
390​	1,333361111111110​
400​	1,333333333333330​

 

[Lu76Fer]

Chez moi, les calculs en fonction du Zoom sont plus précis en partant du PixelToPoint de la fonction de @Lu76Fer du Post #40.
Le fait de partir sur un PointToPixel donne des résultats variables sur la 3ème voire 2ème décimale en fonction du Zoom (chez moi et je sais PAS chez toi en mémoire de vieux tests).
Regarde la pièce jointe 1180794
Ça vaut évidemment pour des conversions PixelToPoint de type 0.6 ou 0.75. Je ne sais pas s'il existe des conversions PixelToPoint dont les décimales sont plus nombreuses.

Voici une version détaillée de mon calcul de PxToPt car je ne suis pas sûr que mes explications soit très clair :

Sub SetPxToPt2()
Dim x As Long
    x = 600 'Prendre une valeur élevée > 500
    With ActiveWindow
        PxToPt = x / (.Panes(1).PointsToScreenPixelsX(x * 100 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))
        PxToPt = Round(20 * PxToPt) / 20  'la valeur obtenue finie toujours par 0 ou 5.
    End With
    Debug.Print PxToPt
End Sub

L'avantage en prenant PxToPt c'est que la valeur finie d'après mes observations par un 0 ou un 5 sur la deuxième décimale. Du coup avec un arrondi si on trouve 0.7668996 cela devient 0.75 ou 059876 devient 0.60
Du coup je trouve quelque soit le zoom (déjà testé) pour les entiers de 10 à 400 :
PxToPt=0.60 soit PointToPixel=1.66666666666667
J'espère que c'est plus clair.

 

[patricktoulon]

j'avoue il fallait y penser à l'arrondi vba 2 decimales

 

[Dudu2]

En effet, c'est ce que j'ai dit.
En partant d'un PixelToPoint on arrive facilement à 0.6 ou 0.75 que ce soit avec la fonction de @Lu76Fer ou celle de @Dudu2 corrigée @patricktoulon qui part d'un PointToPixel.

Pour la 2ème il suffit d'inverser le résultat pour partir d'un PixelToPoint plus facile à calculer et qui finit par ressembler à la 1ère.

Function PixelToPoint() As Double
    Dim ZoomRatio As Single
    Const K1 As Long = 72000
 
    With ActiveWindow.Panes(1)
        ZoomRatio = .Parent.Zoom / 100
        PixelToPoint = Round(1 / ((.PointsToScreenPixelsX(K1 / ZoomRatio) - .PointsToScreenPixelsX(0)) / K1), 2)
    End With
End Function

 

[patricktoulon]

re
bonjour
une adaptation

Function PtToPixel(Optional sens As Long = 0)
' méthode @lu76Fer sur exceldownloads
    With ActiveWindow
        PtToPixel = 7200 / (.Panes(1).PointsToScreenPixelsX(7200 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0)) / 100
        PtToPixel = Round(20 * PtToPixel) / 20
    End With
    If sens = 1 Then PtToPixel = 1 / PtToPixel
End Function
Sub test()
    MsgBox PtToPixel & vbCrLf & PtToPixel(1)
End Sub

 

[patricktoulon]

re
oui c'est plus facile d'aller chercher l'arrondi du coeff multiplicateur
adaptation des deux

Function PtToPixel(Optional sens As Long = 0)
' méthode @lu76Fer sur exceldownloads
    With ActiveWindow
        PtToPixel = 7200 / (.Panes(1).PointsToScreenPixelsX(7200 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0)) / 100
        PtToPixel = Round(20 * PtToPixel) / 20
    End With
    If sens = 1 Then PtToPixel = 1 / PtToPixel
End Function

Sub test()
    MsgBox PtToPixel & vbCrLf & PtToPixel(1)
End Sub


Function PixelToPoint(Optional sens As Long = 0) As Double
    'adaptation  @dudu2 patricktoulon
    Dim ZoomRatio As Single
    With ActiveWindow.Panes(1)
        ZoomRatio = .Parent.Zoom / 100
        PixelToPoint = Round(1 / ((.PointsToScreenPixelsX(7200 / ZoomRatio) - .PointsToScreenPixelsX(0)) / 7200), 2)
    If sens = 1 Then PixelToPoint = 1 / PixelToPoint
    End With
End Function

Sub test2()
MsgBox PixelToPoint & vbCrLf & PixelToPoint(1)
End Sub

que l'on me dise encore qu'il faut les apis pour calculer ça

en tout cas merci @Lu76Fer
ça ne m'est pas venu à l'idée d'aller chercher le multiplicateur pour l'arrondir
ce qui est plus facile avec un nombre pair mod 10
Utiliser le défaut de vba qui arrondi a son avantage j'adore
bravo pour l'astuce

 

[Dudu2]

Bonjour à tous,
Quant à ce calcul dans le code de @Lu76Fer je viens enfin de le comprendre !
Faut dire que les choses sont particulièrement alambiquées et masquées !

Sub SetPxToPt()
    With ActiveWindow
        PxToPt = Round(11520 / (.Panes(1).PointsToScreenPixelsX(57600 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))) / 20
    End With
End Sub

Il peut se traduire par:

Sub SetPxToPt()
    With ActiveWindow
        PxToPt = Round(20 * (11520 / 20) / (.Panes(1).PointsToScreenPixelsX((11520 / 20) * 100 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))) / 20
    End With
    MsgBox PxToPt
End Sub

et en réduisant:

Sub SetPxToPt()
    With ActiveWindow
        PxToPt = Round(11520 / (.Panes(1).PointsToScreenPixelsX(11520 * 5& / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))) / 20
    End With
    MsgBox PxToPt
End Sub

Et donc pourquoi "* 5" ? Par ce que c'est 100 / 20 (le 100 étant pour le Zoom)

Purée ! quel calcul alambiqué.
Je préfère quand même la fonction du Post #48 !

 

[Lu76Fer]

Bonjour et Merci !
Cela fait plaisir d'être compris !

 

[Dudu2]

Toujours à essayer de bien comprendre... l'intérêt d'un Round(k * 20) / 20 par rapport à un Round(k, x).

k = 5.7316
Round(k * 20) / 20 = 5.75
Round(k , 2) = 5.73

Il me semble que Round(k , 2) est plus proche de la réalité, non ?

Alors en effet Round(k * 20) / 20 permet de terminer la valeur par soit 0 soit 5, ce qui est pratique quand c'est un objectif de calcul. Mais en l'occurrence doit-on forcément avoir le ratio Pixel To Point se terminer par soit 0 soit 5 ?

 

[patricktoulon]

re
c'est pas alambiqué du tout
c'est simple
au lieu d'aller chercher le coeff diviseur on va chercher le coeff multiplicateur
1/...........
ensuite on laisse vba l'arrondir par défaut avec un nombre pair mod 10
PtToPixel = Round(20 * PtToPixel) / 20
c'est simple comme Bonjour

 

[patricktoulon]

re

Alors en effet Round(k * 20) / 20 permet de terminer la valeur par soit 0 soit 5, ce qui est pratique quand c'est un objectif de calcul. Mais en l'occurrence doit-on forcément avoir le ratio Pixel To Point se terminer par soit 0 soit 5 ?

très bonne question
la réponse est théoriquement non ,mais en pratique oui
sauf si tu joue avec la résolution personnalisée dans window
sinon tu n'a que
dpi 100
dpi 125
dpi 144
qui sont gérés nativement par windows
le reste ben bon courage

 

[Dudu2]

La question n'est pas tant ce qui est réellement possible mais simplement pourquoi fermer les options avec une méthode de calcul qui limite à une approximation à 0 ou 5 quand on peut avoir une approximation de 0 à 9 ?
Je pose seulement la question de l'intérêt de ce calcul.

L'alambiqué c'était ça, qui n'est pas cette question d'arrondi:

PxToPt = Round(11520 / (.Panes(1).PointsToScreenPixelsX(57600 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))) / 20

Décortiqué en Post #53.

 

[Lu76Fer]

Je suis parti de cette observation que ce coef PxToPt finissait toujours par 0 ou 5 mais j'aurai eu besoin de la confirmation d'autres utilisateurs car j'ai que 2 écrans et sur un j'ai un coef de 0.75 et sur l'autre 0.60. Cela reste faible comme observation statistique !
Sinon j'ai l'autre méthode qui consiste à chercher la hauteur de ligne la plus faible possible (soit 1 pixel) et j'interroge Excel pour connaitre la correspondance en point :

'Calcul du ratio Pixel/Point
'Méthode : détermination de la taille en point de la plus petite hauteur d'une cellule (1 pixel)
'Recherche par 'tatonnement'
Sub SetPxToPtV11()
Dim crtRH#, dMem#, pxSz#, dTmp#
Dim isHide As Boolean, isScrUpd As Boolean
    isScrUpd = Application.ScreenUpdating: If isScrUpd Then Application.ScreenUpdating = False
    With ActiveSheet.Rows(1)
        If .Hidden Then
            isHide = True: .Hidden = False
        End If
        dMem = .RowHeight
        Do
            crtRH = crtRH + 1
            .RowHeight = crtRH: pxSz = ActiveSheet.Rows(2).Top
        Loop While pxSz = 0
        crtRH = pxSz
        Do
            PxToPt = pxSz
            crtRH = crtRH - 0.1
            .RowHeight = crtRH: pxSz = ActiveSheet.Rows(2).Top
        Loop Until pxSz = 0
        .RowHeight = dMem
        If isHide Then .Hidden = True
    End With
    If isScrUpd Then Application.ScreenUpdating = True
End Sub

Mais du coup c'est beaucoup plus long au niveau du code ...

 

[Dudu2]

De toutes façons ces considérations sur des notions supposées acquises et définies sont très intéressantes.
Personnellement j'en ai tiré des enseignements sur la manière de faire.
1 - Partir d'un calcul Pixel To Point selon la méthode de @Lu76Fer car c'est beaucoup plus sûr.
2 - Se contenter d'un arrondi à 2 décimales
3 - D'où les fonctions:

Function PixelToPoint() As Double
    Const K1 As Long = 10000
   
    With ActiveWindow
        PixelToPoint = Round(K1 / (.Panes(1).PointsToScreenPixelsX(K1 * (100 / .Zoom)) - .Panes(1).PointsToScreenPixelsX(0)), 2)
    End With
End Function

Function PointToPixel() As Double
    PointToPixel = 1 / PixelToPoint
End Function