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
@Dudu2 ben sur que les données ne changent pas
c'est justement ce que j'essaie d'expliquer
je dois mal parler le français sans doute

 

[Dudu2]

Ok, alors j'ai mal compris ce que tu voulais démonter

 

[patricktoulon]

ce que j'ai voulu demontrer c'est que le width -indewidth et pareil pour le height te donneront toujours la même chose avec quelque thème windows que ce soit
sauf que la dwmapi.dll modifie la barre de titre et/ou les bordures

 

[Dudu2]

En effet, cette information ne change pas quelque soit le thème en cours.
Chez moi 10.8 points.

Exemple Aero Light:

Exemple Thème par défaut Windows 10:

Sans correction des marges via l'API, en thème par défaut Windows 10 on retrouve le décalage du code de @Lu76Fer. Alors ce n'est pas majeur mais la précision peut être utile dans certains cas (intellectuellement au moins !).

 

[Dudu2]

Alors, pour poursuive la discussion précédente, tu vas me dire...
"Tu vois, tu ne peux pas te baser sur la valeur du (Width - InsideWidth) pour corriger les marges"
(10.8 chez moi en Windows 10, 4.8 chez toi en Windows 7)

Ce sur quoi je suis parfaitement d'accord.
Mais ce qui m'intéresse c'est de savoir ce qui se passe sur le Thème par défaut qui a toutes les chances d'être commun à une version de Windows même si dans les paramètres d'Effets Visuels, quelques cases sont modifiables mais sans effet sur le UserForm (j'ai testé).

Edit: pour la forme je vais peut-être lancer un sujet de test

 

[patricktoulon]

ben le thème par défaut est très proche des données données par getsystemmetric
pour te la faire courte
avant sur XP(sp(1,2,3) c'est la user32.dll et smagina.dll puis la uxthème.dll qui s’occupait de l'affichage des fenêtres et ces 3 dll produites en même temps était parfaitement syncro

depuis VISTA
c'est wmapi.dll qui a fait son apparition pour les effet aero Glass blind ,etc.. mais n'est pas syncro
c'est un ordre supplémentaire qui est fait sur l'affichage(un patch quoi)
depuis W7 sp1 ,la wmapi.dll a été corrigé sur les version 64 (pas sur le 32)
d'ailleurs certaines fonctions de cette api fonctionnent en vba7 64 bits mais pas en 32
sur W10 il on enlevé le glass, c'est a ce demander pourquoi il on garder la wmapi.dll

bref le thème par défaut(même lui) ne sera pas le même sur plusieurs pc de revendeurs différents
(Hp ,lonovo ,acer ,asus, etc..)
mais il seront très proches quand même
d’où l'astuce que je t'avais donné (l'interrogation du rectangle avec wmapi.dll)
ça fait plus de 15 ans que je tourne autour (et pas que moi d'ailleurs)
mais rien n'a été trouvé de plus simple

et le pire dans tout ça c'est que dès que tu passe en dpi sup ou inf à 100% ben la c'est la bérésina
tu à mis le test de dwm dans tes fonctions ben c'est tout ce que tu peux faire

ou sinon exclure le userform de la liste des fentre du desktop en l'affiliant à l'application par exemple tout simplement :mais tu perd le design w10

 

[patricktoulon]

regarde le userform quand tu l'exclu de dwm wmapi

Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr

Private Sub CommandButton1_Click()
    Dim HwnD As LongPtr
    HwnD = GetActiveWindow
    SetParent HwnD, Application.HwnD
    With ActiveWindow.Panes(1)
        l = .PointsToScreenPixelsX(0) * 0.75    '0.6 pour le dpi 120 à la place de 0.75
        t = .PointsToScreenPixelsY(0) * 0.75 * 1.022   'pareil
    End With
    Me.Left = [F4].Left + l
    Me.Top = [F4].Top + t
End Sub

 

[Dudu2]

Ok, tu en sais beaucoup plus que moi sur l'historique et le fonctionnement de ce bidule.

Il y aurait une alternative à l'API à étudier qui est la couleur à 1 pixel du Top et 1 pixel du Left du UserForm.
en Windows 10/64, comme la marge est un genre de transparence dégradée, à 1 point le RGB est très proche de la couleur de fond de la cellule mais légèrement different. Je viens de le vérifier avec l'API GetPixel().
Le décalage serait donc à faire si on est dans les conditions de transparence.

Mais bon, je ne vais pas me lancer là-dedans, car ça nécessiterait encore des tests et je fatigue sur ce sujet

. Gardons l'API.

 

[patricktoulon]

ben c'est tout simplement l'api getpixel
tu fait un getpixel sur le hdc du desktop sur le left et top du getwindowsrect de l'userform
mais bon ça devient vite une usine à gaz
le test dwm est bien suffisant

 

[Dudu2]

Un dernier point pour @Lu76Fer ou toute autre personne...
Où as-tu récupéré ce calcul que je ne comprends absolument pas !?
Pourquoi * 5 ? Pourquoi / 20 ?

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

 

[Lu76Fer]

Un dernier point pour @Lu76Fer ou toute autre personne...
Où as-tu récupéré ce calcul que je ne comprends absolument pas !?
Pourquoi * 5 ? Pourquoi / 20 ?

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

Cela ressemble à ce que j'avais repris et arrangé pour arrondir PxToPt à 2 chiffres après la virgule et qui fini toujours par 0 ou 5 mais c'est mieux de prendre des gros chiffres pour être sûr de ne jamais avoir un mauvais arrondie :

' PxToPt = x / (.Panes(1).PointsToScreenPixelsX(x * 100 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))
' PxToPt = Round (20 * x) / 20 'la valeur obtenue finie toujours par 0 ou 5.
' La valeur est approximative mais en prenant une valeur x élevé on peut obtenir une valeur suffisament
' précise pour être arrondie à 2 chiffres après la virgule qui fonctionne pour toutes les valeurs de Zoom.
Sub SetPxToPt()
    With ActiveWindow
        PxToPt = Round(11520 / (.Panes(1).PointsToScreenPixelsX(57600 / .Zoom) - .Panes(1).PointsToScreenPixelsX(0))) / 20
    End With
End Sub

Il y a aussi d'autre méthode confère 'GetScreenPosDemo2' module lib & libV11

 

[Dudu2]

Oui c'est ta fonction que j'ai adaptée et dont je ne comprends pas bien les termes.
Perso, en approximation (donc hors API) j'avais écrit celle-ci dont les termes sont intuitifs (enfin je présume).

Function PointToPixel() As Double
    Dim ZoomRatio As Single
    Const K1 As Long = 10000
    
    With ActiveWindow.ActivePane
        ZoomRatio = .Parent.Zoom / 100
        PointToPixel = Round(((.PointsToScreenPixelsX(K1) - .PointsToScreenPixelsX(0)) / K1) / ZoomRatio, 2)
    End With
End Function

 

[patricktoulon]

re
@Dudu2 c'est ma fonction avec des données différentes
cependant tu fait une erreur et dieu sait que j'ai passé du temps a te l'expliquer
le zoom ce n'est pas la qu'il faut l'opérer
car le le redis
dans la distance des bords de l'ecran left ou top à k1 tout n'est pas zoomé par excel

donc je repete
tout d'aborrs c'est la panes(1) qu'il faut prendre pour ce calcul(compatibilité 2007 à 365)
ensuite c'est le positif qu'il faut zoomer ou dézoomer

 Sub test()
K1 = 72000
With ActiveWindow.Panes(1)
        ZoomRatio = .Parent.Zoom / 100
        PointToPixel = (.PointsToScreenPixelsX(K1 / ZoomRatio) - .PointsToScreenPixelsX(0)) / K1
    End With
MsgBox "coeff diviseur " & PointToPixel & vbCrLf & "soit" & vbCrLf & "coeff multiplicateur " & 1 / PointToPixel
End Sub

 

[Dudu2]

Ok, j'ai confondu. Évidemment qu'en Point 0 il ne peut pas y avoir de zoom.
Ceci dit je n'utilise que l'API pour cette conversion, pour avoir des chiffres précis.

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

 

[Dudu2]

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

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