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

Lu76Fer · 23 Septembre 2023

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

Cousinhub · 12 Octobre 2023

Zut,
Suspens en sursis....
Mais est-ce que l'usf qui allait commander le mail sur Thunderbird était bien à la croisée des chemins de la colonne F et de la ligne 4??????

Dudu2 · 12 Octobre 2023

Dans ce cas, enlève ton Sleep...

J'y ai pensé mais mon éducation me l'interdit.

patricktoulon · 12 Octobre 2023

re
WshShell.SendKeys "^{ENTER}"
fait apparaitre la petite fenêtre d’envoi mais ne valide pas l'envoi
moi je fait comme ça

VB:

Sub envoi_mail()

    Dim destinataire$, sujet$, body$, PJ$, wshell As Object

    destinataire = "moi@outlook.fr"

    sujet = "salut"
    corpmessage = "bonjour bonjour"

    scriptCommand = "C:\Program Files\Mozilla Thunderbird\thunderbird.exe"
    scriptCommand = scriptCommand & " -compose " & "to='" & destinataire & "'"
    scriptCommand = scriptCommand & "," & "subject=" & sujet & ","
    scriptCommand = scriptCommand & "body='" & Chr(34) & corpmessage & Chr(34) & "'"


    'chemin = "c.\blablabla"
    'scriptCommand= strcommand & "," & "attachment='file:///" & chemin & "'"
     Shell scriptCommand, vbNormalFocus
   
    Application.Wait Now() + 0.00001
    SendKeys "^{ENTER}"    ', False    'faire apparaitre la petite fenêtre d'envoi
   
    Application.Wait Now() + 0.00001
   'comme on a fait un sendkey direct on en refait un VIDE !!! pour débloquer le numlock
 SendKeys ""    'rebloque le numlock
 'maintenat on envoie la touche enter mais avec le wscrip.shell 
set wshell = CreateObject("wscript.shell")
    wshell.SendKeys "{ENTER}"    'appuie sur enter le bouton envoyer ayant le focus

End Sub

peut être saura tu faire la différence entre
sendkeys
application.sendkeys
createobject("wscript.shell").sendkeys

c'est un très bon exemple pour démontrer les particularité des 3 méthodes

Dudu2 · 12 Octobre 2023

fait apparaitre la petite fenêtre d’envoi mais ne valide pas l'envoi

Chez moi j'ai coché "Ne plus afficher" sur la petite fenêtre donc je n'ai pas ce problème.
Mais ça peut être utile pour un code général.

Les 3 méthodes de SendKeys en VBA je les ai documentées il y a plusieurs années dans mes fichiers.
En VBScript le WshShell.SendKeys ne me pose pas de problème de NUMLOCK, je l'ai donc gardé comme ça.

Dudu2 · 12 Octobre 2023

D'ailleurs j'aimerais bien restorer cette option mais c'est planqué dans les sous-sols.

Dudu2 · 12 Octobre 2023

Ça y est, je l'ai.

Dudu2 · 12 Octobre 2023

Alors attention.
Si l'option n'est pas cochée et que tu renvoies un 2ème ENTER un peu tard, ça va faire ENTER sur la fenêtre de départ et si c'était sur le .vbs, ça va le lancer en boucle !
Perso j'ai fait un Sleep 30 entre les 2 de sorte que le ENTER arrive encore sur la fenêtre Thunderbird même si y a pas l'option et si y a l'option, ça ferme bien la petite fenêtre.
Code du Post #105 modifié.

patricktoulon · 12 Octobre 2023

re
oui donc c'est pas top
car ceux qui n'on pas cocher "ne plus afficher" ce sera problématique
pour ce genre de truc malgré que je soit un vbiste indécrottable
et dieu sait que j'en ai bouffé du vbs et du vb6
je préfère de loin travailler avec uiautomationclient
cela dit on s'égare ,ce n'est pas le sujet de ce topic

Dudu2 · 12 Octobre 2023

Oui on s'égare, mais au point où on en est !
De toutes façons, le sujet on l'a épuisé non ? En tous cas, le sujet m'a épuisé moi ;
Je verrai demain tes trucs de Drivers de carte graphique, mais j'ai vraiment la pétoche de redémarrer sur un écran noir après modif.

TooFatBoy · 12 Octobre 2023

Dudu2 à dit:
Je verrai demain tes trucs de Drivers de carte graphique, mais j'ai vraiment la pétoche de redémarrer sur un écran noir après modif.

Effectivement, si tout fonctionne, ne change rien, et surtout ne prends pas les drivers n'importe où !

patricktoulon · 12 Octobre 2023

il n'y a aucune raison de s'inquiéter
ton ordinateur va redémarrer en en 1200 par 720 et
soit il va se mettre en résolution max tout seul soit il faudra que tu le fasse par toi même
mais attention je le redis "par l'interface NVIDIA" pas par le panneau windows

dis toi que des drivers ayant obtenu la certification WHQL par Microsoft sont les meilleurs dipos pour tes pièces du pc
ça aussi c'est immuable

j'attire ton attention

il est clair a la vue de cette capture que tu tourne avec les drivers boiteux de crosoft

Dudu2 · 13 Octobre 2023

Si tu le dis...
Si ça foire je viens à Toulon avec l'ordi

Dudu2 · 13 Octobre 2023

Bonjour,
Au passage j'ai modifié le code du Post #105 pour ajouter une constante qui reflète l'option décrite en commentaire. Comme ça c'est "carré" et sans ambigüité.

Sinon j'ai fait la manip et j'ai maintenant le driver NVIDIA.

A l'exécution du code habituel j'ai toujours les mêmes valeurs en résolution 1920 x 1080 (natif).

patricktoulon · 13 Octobre 2023

bonjour
@Dudu2 promène toi dans le paneau de config nvidia il doit y avoir quelque chose qui n'est pas coché

pour l'expérience je suis monté en résolution native chez moi en dpi250%
bon quand je suis redescendu en résolution l'enregistrement devient plus petit mais a mon écran c’était toujours plein écran

TooFatBoy · 13 Octobre 2023

patricktoulon à dit:
pour l'expérience je suis monté en résolution native chez moi en dpi250%

Quelques petites erreurs...
Le DPI ne se donne pas vraiment en pourcentage, donc "dpi250%" ne veut pas dire grand chose.
Mais surtout, je crois que tu n'as pas lu ce qui est écrit : il me semble qu'en passant à 250 %, ce n'est pas la résolution que tu changes.

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

Lu76Fer

XLDnaute Occasionnel

Pièces jointes

Cousinhub

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

Discussions similaires