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

 

[patricktoulon]

re
oui le regread reste la meilleure solution sans api puisque pris à la source (base de registre)
je ne la propose plus trop car très souvent on me rétorque que l'accès a la BDR est dangereuse
je vois pas trop ce qu'une simple lecture peut avoir de dangereux mais bon

la 2d raison c'est que certains pc (professionnels) ont le wscript.exe bloqué donc wscript.shell bye bye

après la getdevicecap c'est juste l’exécution en macro 4 sauf que là il faut activer les macro 4 sur 2021

bref vous l'avez compris plus on va de l'avant moins nous est permis de choses
pour ma part j'ai adopté ma formule mais avec l'idée de lu76fer qui est de ramener me pixel to point à point to pixel
avec la simple idé du "1/ par" et pour le correctif wmapi.dll veille au grain

 

[patricktoulon]

re
juste pour rire
api sans calcul pixel
dans le userform

Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal HwnD As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal HwnD As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public OBJ As Object
Function showX(OBJ)
    Unload UserForm1
    With UserForm1
        Set .OBJ = OBJ
        .Show
    End With
End Function
Private Sub UserForm_Activate()
    Dim HwnD&, r As RECT, X#, Y#, W#, H#
    HwnD = GetActiveWindow
    GetWindowRect HwnD, r
    W = Fix((r.Right - r.Left))
    H = Fix((r.Bottom - r.Top))
    X = ActiveWindow.ActivePane.PointsToScreenPixelsX(Fix(Int(OBJ.Left)))
    Y = ActiveWindow.ActivePane.PointsToScreenPixelsY(Int(OBJ.Top))
    SetWindowPos HwnD, 0, X, Y, W, H, 0
End Sub

dans la feuille

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
       UserForm1.showX Target
End Sub

bon d'accords je sorts

 

[Dudu2]

Pas mal vu !

 

[Lu76Fer]

Cela dit, suite à une anomalie que j'avais corrigé je rajouterai cela :

Function showX(OBJ)
    Unload UserForm1
    With UserForm1
        Set .OBJ = OBJ
        .Show
    End With
    DoEvents    'Car sinon dans certain cas Hwnd risque de pointer sur le mauvais Objet
    'Notamment si une application est déjà ouverte
End Function

 

[patricktoulon]

Cela dit, suite à une anomalie que j'avais corrigé je rajouterai cela :

Function showX(OBJ)
    Unload UserForm1
    With UserForm1
        Set .OBJ = OBJ
        .Show
    End With
    DoEvents    'Car sinon dans certain cas Hwnd risque de pointer sur le mauvais Objet
    'Notamment si une application est déjà ouverte
End Function

?????????????????????????????????????????
vous avez vraiment de pcs avec des réactions bizarre
le HwnD est capté a l'activate je ne vois aucune raison que se soit pour qu'il y est erreur sur la fenêtre
ça serait remettre en cause le principe même de l'event activate et du getActiveWindow

 

[Dudu2]

J'en ai fait un dérivé de ma version de position avec correction des marges en utilisant la méthode @patricktoulon pour le positionnement car ça va assez bien avec vu qu'il faut le Handle du UserForm pour le WindowRECT et le ExtendedFrameRECT.

 

[patricktoulon]

re
là si personne trouve son bonheur je vous dis il faut faire du tricot
avec ou sans api

je résume

1. sans api il nous faut accepter l'approximation avec width-insidewidth
2. avec api normalement la wmapi.dll doit te donner la différence en fonction du thème Windows appliqué

avec api 2 possibilités​

• position calculée pointstopixel et vice et versa
• position non calculée avec setWindowPos

 

[Dudu2]

Ça c'est sûr, y a du choix.

J'ai modifié le fichier ci-dessus (Post #156) pour éviter l'effet visuel de décalage (certes ultra-rapide) sur les Custom Shifts en les intégrant dans les calculs X et Y avant le SetWindowPos au lieu de corriger a posteriori les UserForm.Left/.Top.

D'ailleurs avec le WindowRECT.Left et le UserForm.Left, on peut calculer le ratio Pixel To Point qui en l'occurrence ne sert à rien mais c'est possible.

 

[Lu76Fer]

?????????????????????????????????????????
vous avez vraiment de pcs avec des réactions bizarre
le HwnD est capté a l'activate je ne vois aucune raison que se soit pour qu'il y est erreur sur la fenêtre
ça serait remettre en cause le principe même de l'event activate et du getActiveWindow

Simple constat ! Il arrive que les évènements ne se déroulent pas dans le bonne ordre ce qui doit être le cas dans ma demo2 et getActiveWindow ne récupère pas le bon Handle.
DoEvents est indispensable dans certaines parties du code car il laisse la main à excel et permet aux évènements de se dérouler jusqu'au bout.
Je ne sais pas comment tout cela est géré mais le test est sans appel !
Dans mon cas je charge le handle une seule fois au démarrage du coup ce n'est pas tout à fait pareil ...

 

[Dudu2]

@Lu76Fer, tu dois avoir un souci avec le fichier du Post #156 car je n'ai pas de DoEvents entre le .Show et le GetActiveWindow.

 

[Lu76Fer]

@Lu76Fer, tu dois avoir un souci avec le fichier du Post #156 car je n'ai pas de DoEvents entre le .Show et le GetActiveWindow. Essayer avec vbModeless et vbModal.

Pas compris ... Je suggère de rajouter DoEvents en faite, c'est tout.

 

[Dudu2]

Ok, ça mange pas de pain !

 

[Lu76Fer]

Bonjour Lu76Fer,
Vous devriez postez votre utilitaires dans nos ressources :

Téléchargements

excel-downloads.com

Peut être dans : https://excel-downloads.com/resources/categories/utilitaires.18/
Cela permettrait d'être plus visible car dans les posts il va vite devenir noyé parmi la multitude.

Bonsoir Sylvanu,
Après quelques révisions j'ai ajouté cette démo aux ressources du site notamment en utilisant de façon plus convenable les fonctions systèmes et ajout d'une option pour montrer comment réduire et afficher le UserForm sans contrainte de taille minimale :
Démo pour positionner un UserForm ou ContextMenu sur la grille (Toute version)

Merci à PatrickToulon et Dudu2 pour leur participation active

 

[Lu76Fer]

Function PixelToPoint() As Double
    Dim K1 As Long
 
    K1 = Application.InchesToPoints(20)
 
    With ActiveWindow
        PixelToPoint = Round(K1 / (.Panes(1).PointsToScreenPixelsX(K1 * (100 / .Zoom)) - .Panes(1).PointsToScreenPixelsX(0)), 2)
        'PixelToPoint = K1 / (.Panes(1).PointsToScreenPixelsX(K1 * (100 / .Zoom)) - .Panes(1).PointsToScreenPixelsX(0))
        'PixelToPoint = 1 / ((.Panes(1).PointsToScreenPixelsX(K1 / (.Zoom / 100)) - .Panes(1).PointsToScreenPixelsX(0)) / K1)
    End With
End Function

Bonjour,
On m'a demandé d'expliquer cette formule suite à quoi je me suis rendu compte que ce n'était pas si évident ...
Du coup, j'ai ajouté dans mon équation un Epsilon que j'appèlerai 'E' pour voir comment réduire l'erreur (en augmentant K1 bien sûr) et j'ai vu que celui-ci intervenait sur le dénominateur.
Formule Simplifiée :
PixelToPoint= K1 / (Distance - E)
Du coup l'idéal est de maximiser Distance par rapport à E (l'erreur)
K1 étant pris au hasard on peut choisir K1=C1 * Zoom
La fonction devient :

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

Après test c'est beaucoup plus précis car cela marche avec K1=10 pour toutes les valeurs de zoom.
J'attend ton avis

 

[patricktoulon]

re
bonjour @Lu76Fer
je suis hors course là car pour moi ça sera toujours bon
je suis assez déapointé de voir tout ce vous déployez pour obtenir le coeff

pour moi le calcul est simple
une valeur en pixel / la même valeur en point te donne le coeff descendeur le 1/ par ... te donne le coeff remonteur
mais j'ai quand même testé

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


Sub test()
    MsgBox SetPxToPt
End Sub

testons ma méthode
alors pour les tests je l'ai testé sur mon W7 en dpi125 et mon W10 en dpi100 qui change pas avec le zoom windows
et là pour le coup j'ai bien le dpi 125% sur mon W7
windows 7

windows 10

mes chiffres sont bons

Function GetpxToPt()
    Dim k1, k2
    k1 = 15
    With ActiveWindow
        Z = .Zoom / 100
        'comment obtient on 15 points  en pixel?
        k2 = .Panes(1).PointsToScreenPixelsX(k1 / Z) - .Panes(1).PointsToScreenPixelsX(0)
        pttopx = k2 / k1
        pxtopt = 1 / pttopx
        texte = texte & "k1 en point vaut : " & k1 & vbCrLf
        texte = texte & "k1 en pixel vaut : " & k2 & vbCrLf
        texte = texte & "pixelToPoint = " & pxtopt & vbCrLf
        texte = texte & "pointToPixel = " & pttopx & vbCrLf
        texte = texte & "on est donc en DPI : " & pttopx / (4 / 3) * 100 & "%"
    End With
    MsgBox texte
    GetpxToPt = pxtopt
End Function

Sub test2()
    MsgBox GetpxToPt
End Sub

les résultats chez moi sont logiques et justes