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

Lu76Fer

XLDnaute Occasionnel
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 :
VB:
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.
VB:
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 :
VB:
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
Code:
Call InitLibV11
par
Code:
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
 

Pièces jointes

  • GetScreenPosDemo.xls
    177.5 KB · Affichages: 14
  • GetScreenPosDemo.xlsm
    106.5 KB · Affichages: 24
Dernière édition:

Cousinhub

XLDnaute Barbatruc
Au moins, je fais l'unanimité...
Et donc, toute cette discussion va améliorer Excel...
Ps, pour le moko (oui, je l'ai refait)
honte à moi même de te te répondre

"N'aies aucune honte à répondre à qui que ce soit, surtout si on s'avise à te contre-dire, ce qui, de ton propre jugement, n'est pas concevable. Allant jusqu'à poser des questions, pour au final, demander d'arrêter de répondre, car tu as trouvé tout seul, comme un grand"....
Bonne soirée
 

Dudu2

XLDnaute Barbatruc
OK, merci pour l'info de passage des arguments.
Pour l'instant je ne l'ai envisagé que comme script VBS à insérer dans le dossier StartUp du PC pour envoyer un mail à chaque démarrage. Mais ça pourra être utile en interfaçage Excel si besoin.
 

Dudu2

XLDnaute Barbatruc
Si ça peut te rassurer, à part la justesse des calculs vérifiée dans leur application sur l'affichage des objets Excel, beaucoup de choses m'échappent dans ces considérations de Résolution native / Résolution définie / Pixels / Points / Mise à l'échelle / Zoom etc...

Mais au fond, je ne sais pas si ça m'intéresse tant que ça d'aller au fond de ces considérations, à partir du moment où les calculs donnent le résultat escompté.
 
Dernière édition:

TooFatBoy

XLDnaute Barbatruc
Si ça peut te rassurer, à part la justesse des calculs vérifiée dans leur application sur l'affichage des objets Excel, beaucoup de choses m'échappent dans ces considérations de Résolution native / Résolution définie / Pixels / Points / Mise à l'échelle / Zoom etc...

Mais au fond, je ne sais pas si ça m'intéresse tant que ça d'aller dans ces considérations, à partir du moment où les caulcs donnent le résultat escompté.
Je crois que pour moi c'est l'inverse. 😅


Bonne soirée
🖖
 

patricktoulon

XLDnaute Barbatruc
diabolo.gif
 

Dudu2

XLDnaute Barbatruc
Si ça peut te rassurer, à part la justesse des calculs vérifiée dans leur application sur l'affichage des objets Excel, beaucoup de choses m'échappent dans ces considérations de Résolution native / Résolution définie / Pixels / Points / Mise à l'échelle / Zoom etc...

Mais au fond, je ne sais pas si ça m'intéresse tant que ça d'aller au fond de ces considérations, à partir du moment où les calculs donnent le résultat escompté.
C'est déjà assez difficile comme ça d'avoir les bons calculs !
1697223716149.gif
 

Lu76Fer

XLDnaute Occasionnel
Au moins, je fais l'unanimité...
Et donc, toute cette discussion va améliorer Excel...
Ps, pour le moko (oui, je l'ai refait)


"N'aies aucune honte à répondre à qui que ce soit, surtout si on s'avise à te contre-dire, ce qui, de ton propre jugement, n'est pas concevable. Allant jusqu'à poser des questions, pour au final, demander d'arrêter de répondre, car tu as trouvé tout seul, comme un grand"....
Bonne soirée
"Moi je dis toujours la vérité ! Et même quand je mens c'est vrai."
Tony Montana dans Scarface.
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Bonjour,
Un petit retour sur la conversion Pixel To Point SANS API que jusqu'à présent je n'utilise pas à cause des imprécisions en Zoom < 50% chez moi et sûrement chez @TooFatBoy qui a la même config et sans doute aussi chez @Lu76Fer (sauf à utiliser l'arrondi 0 ou 5 qui est quand même restrictif).

Une solution qui fonctionne à 100% est celle-ci, copiée d'un post de @patricktoulon dans je ne sais quel sujet.
VB:
Function PointToPixel() As Double
    Static SavePointToPixel As Double
 
    If SavePointToPixel = 0 Then
        SavePointToPixel = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1)
    End If
    PointToPixel = SavePointToPixel
End Function

J'ai mis un Static pour ne pas créer de Shell à chaque fois en supposant que cette valeur ne change pas d'un moniteur à un autre quand il sont utilisés en parallèle (je crois avoir vu ça dans une doc MS).
 
Dernière édition:

Dudu2

XLDnaute Barbatruc
Il y a aussi cette autre version de @patricktoulon qui fonctionner à 100%:
VB:
Function PointToPixel() As Double
    Dim DC As Long
    Static SavePointToPixel As Double
   
    If SavePointToPixel = 0 Then
        DC = ExecuteExcel4Macro("CALL(""user32"",""GetDC"",""JJJ"",0)")
        SavePointToPixel = ExecuteExcel4Macro("CALL(""gdi32"",""GetDeviceCaps"",""JJJ""," & DC & ", " & 88 & ")") / 72
    End If
    PointToPixel = SavePointToPixel
End Function

Et là le Static est utilisé car les appels successifs à ExecuteExcel4Macro augmentent en CPU au fur et à mesure des exécutions.
 

Discussions similaires

Statistiques des forums

Discussions
312 555
Messages
2 089 551
Membres
104 210
dernier inscrit
mjub