Discussion :

[forum]

Bonjour,

Je vous propose un nouvel élément à utiliser : Insertion de menus dynamiques dans un formulaire Excel

En me basant sur les travaux de Michel Pierron trouvés dans un classeur sur https://www.developpez.net/forums/d7...ubar-userform/, j'ai développé des classes d'objets permettant de bénéficier des fonctionnalités suivantes :



- Aucune limite sur l'insertion d'éléments dans les menus et sous menus

- Aucune limite dans la profondeur de l'arborescence des sous menus d'un menu

- Aucune contrainte de nom des contrôles

- Possibilité d'assigner n'importe quelle procédure à n'importe quelle commande

- Possibilité de réorganiser dynamiquement tout ou partie des menus.



Dans le classeur joint, voici ce qu'il se passe lorsque l'on clique sur le bouton [Modifier les menus]



On s'amuse à réagencer les menus de la manière suivante:

- Le menu Application récupère le menu Aide

- Le menu Commandes correspond au menu Fichiers avant changement

- Toutes les icônes du menu Fichiers changent

- La procédure associée à ce menu devient Aurevoir

- Le sous menu Articles contient tous les autres sous menus



Qu'en pensez-vous ?

[patricktoulon]

bonjour forum
intéressant cette méthode
j'avais proposé quelque chose dans le genre
https://www.developpez.net/forums/d1...lbar-userform/
j'ai pas tout regardé dans tes modules je vais regarder cela je comptais justement accroitre l'arborescence en terme de descendant (msocontrolpopup)

[patricktoulon]

re
bonjour forum
il y a un soucis de placement du menu lors de son affichage

[galopin01]

Bonjour,
Comment utilise-t-on ce genre de téléchargement ? (Celui de forum)

Merci.

[8Tnerolf8]

Bonjour,
Comment utilise-t-on ce genre de téléchargement ? (Celui de forum)

Merci.

Pour une raison qui m'échappe, le classeur télétransmis perd son nom et son extension.

Pour le récupérer, il faut suivre la procédure suivante :

- Télécharger "Menu"
- Renommer ce fichier en y ajoutant l'extension .xlsm

[8Tnerolf8]

re
bonjour forum
il y a un soucis de placement du menu lors de son affichage

Je n'ai pas réussi à reproduire ton bug.

Pourrais-tu, s'il te plaît, décrire les actions que tu effectues et me communiquer la résolution de ton écran pour que je tente de le reproduire ?

[patricktoulon]

re
bonjour
ben j'ouvre simplement son fichier et ouvre l'UserForm et test c'est tout
ma résolution 1920X1080(écran 82 cm)

en fait l'erreur vien de la "4/3) " qui correspond a 1.333333333333333 pour un dpi de de 96 (dpi 100% classique) en fait il faudrait que ce calcul se fasse avec le dpi du pc de l'utilisateur dynamiquement
dans ma contrib je montre comment je fait sans api

le model de forum

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub CtrlLabel_Click()
Dim OffsetX As Double, OffsetY As Double, CoordX As Double, CoordY As Double
With Form
    OffsetX = (.Width - .InsideWidth) / 2
    OffsetY = .Height - .InsideHeight - OffsetX + CtrlLabel.Height + CtrlLabel.Top
    CoordX = (.Left + OffsetX + CtrlLabel.Left) * 4 / 3
    CoordY = (.Top + OffsetY) * 4 / 3
End With
With CtrlLabel
    .SpecialEffect = fmSpecialEffectRaised
    CommandBars(Id).ShowPopup CoordX, CoordY
End With
End Sub

et voila mon model :je fait sans API dans ma contrib

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub CtrlLabel_Click()
    Dim OffsetX As Double, OffsetY As Double, CoordX As Double, CoordY As Double, PPX As Double
    With ActiveWindow.ActivePane
        PPX = (.PointsToScreenPixelsX(Cells.Width) - .PointsToScreenPixelsX(0)) / Cells.Width
    End With
    With Form
        OffsetX = (.Width - .InsideWidth) / 2
        OffsetY = .Height - .InsideHeight - OffsetX + CtrlLabel.Height + CtrlLabel.Top
        CoordX = (.Left + OffsetX + CtrlLabel.Left) * PPX
        CoordY = (.Top + OffsetY) * PPX
    End With
    With CtrlLabel
        .SpecialEffect = fmSpecialEffectRaised
        CommandBars(Id).ShowPopup CoordX, CoordY
    End With
End Sub

demo avec mon astuce sans API


il y a aussi le registre pour capter le coeff pointToPixel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

PtoPX= CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72

sinon tu a l' api gdi"GetDeviceCaps"
voila

[8Tnerolf8]

Bonjour patricktoulon

En me basant sur ta méthode de détermination des coordonnées par API présente dans https://www.developpez.net/forums/d1...lbar-userform/, j'ai consolidé ta méthode dans la fonction RenvoieCoords du module API.

Le classeur à télécharger tient compte de ces changements.

En te remerciant pour tes travaux et pour avoir détecter le bug,
je te souhaite une bonne journée.

[patricktoulon]

re
c'est pas tout a fait bon encore
il faut absolument que dans tes calculs il n'y ai pas d'operateur en dur du genre (-3)
il faut que tu sache aussi que getsystemmetric donne les même valeurs dans tout les Windows alors que c'est faux
il faut aussi prendre en considération pour W7 le theme aero qui modifie encore la chose ainsi que pour W10 qui n'a pas aero mais autre chose
donc

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Public Function RenvoieCoordEcran(Ctrl As Control, Optional PrendEnCpteHauteur As Boolean = True) As Double()
'Cette fonction renvoie les coordonnées du pixel située en haut et à gauche du contrôle Ctrl.
'Elle renvoie un tableau contenant en premier indice l'abscisse (x), en deuxième l'ordonnée (y), et en troisième l'abscisse correspondant à l'extrémité droite du contrôle.
'Si PrendEnCpteHauteur est Vrai, alors l'ordonnée sera celle du coin inférieur gauche du contrôle.
Dim DimCtrl As RECT, XX As Long, YY As Long, ZZ As Long, YiN As Long, HdC As Long, EpS As Long, lpppX As Long, lpppy As Long
Dim Coords(2) As Double
ReDim RenvoieCoordEcran(1)
HdC = GetDC(0): lpppX = GetDeviceCaps(HdC, LOGPIXELSX): lpppy = GetDeviceCaps(HdC, LOGPIXELSY)
GetWindowRect GetActiveWindow, DimCtrl    ' coordonnées rectangle de l'userform
With Ctrl
    XX = .Left * lpppX / 72 'Position Gauche du contrôle cliqué en pixel
    YY = (.Top + IIf(PrendEnCpteHauteur, .Height, 0)) * lpppy / 72 'Position Haut du contrôle cliqué en pixel
    ZZ = (.Left + .Width) * lpppX / 72 'Position du bord droit du contrôle
 
    'les api c'est bien sauf que pour W7 il faut prendre en compte l'aero qui modifie encore la chose
    'en effet selon les versions de W (xp,7,8,10)getsystemmetric donne pareil sauf qu'en réalité ca ne l'ai pas
 
    'YiN = (.Parent.Height - .Parent.InsideHeight - 3) * lpppy / 72  'Epaisseur de la caption du userform en pixel 3 c'est arbitraire
     'EpS = GetSystemMetrics(5) 'Epaisseur des bordures de l' userform en pixel
 
     YiN = (.Parent.Height - .Parent.InsideHeight - ((.Parent.Width - .Parent.InsideWidth))) * lpppy / 72 'Epaisseur de la caption du userform en pixel
     EpS = (.Parent.Width - .Parent.InsideWidth)  'Epaisseur des bordures de l' userform en pixel'on ne divise pas par 2 la logique pourtant le voudrait!!!
   'eps donnera pas la meme chose selon le windows(xp,7,8,10)
    Coords(0) = DimCtrl.Left + EpS + XX
    Coords(1) = DimCtrl.Top + YiN + EpS + YY
    Coords(2) = DimCtrl.Left + EpS + ZZ
End With
RenvoieCoordEcran = Coords
End Function

fait le test en bloquant mes lignes et en débloquant les tiennes et vis et versa et regarde bien les positions left et top des menus

[8Tnerolf8]

Je vais me pencher sur ton dernier message, mais je tiens à précisez que les lignes suivantes proviennent de ton propre code
(https://www.developpez.net/forums/d1...lbar-userform/)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
    If mode = "usf" Then
        GetWindowRect GetActiveWindow, r    ' coordonnées rectangle de l'userform
        XX = bt.Left * lpppX / 72    'position left du label cliqué en pixel
        YY = (bt.Top + bt.Height) * lpppy / 72    ' position top du label cliqué en pixel
        YiN = (bt.Parent.Height - bt.Parent.InsideHeight - 3) * lpppy / 72    ' epaisseur de la caption du userform en pixel
        'YiN = GetSystemMetrics(15) ' autre methode epaisseur de la caption du userform en pixel mais moins precise
        EpS = GetSystemMetrics(5)     ' epaisseur des bordures de l' userform en pixel
        Barre.ShowPopup r.Left + EpS + XX, r.Top + YiN + EpS + YY    ' affichage de la popup au cordonnéees calculées
    Else
        Barre.ShowPopup
    End If

[patricktoulon]

re
oui j' ai reconnu mes anciens codes

mais tu devrais regarder dans la contrib la version sans api il me semble pas que j'utilise des nombres en dur si c'est le cas c'est que je n'ai pas mis ma contrib a jours ,je corrigerais
c'est vrai que très souvent quand je met a jour mes modules, je ne le fait pas tout le temps dans les contrib 3 coup de fouet !!!! pour moi
en ce qui me concerne, les apis dans cet exercice(popup in UserForm) sont superflues on a tout ce dont on a besoins sans ce qui me dégage de multiple déclaration d'api 32/64 etc....
ca m'a donné envie de le refaire avec une arborescence plus grande pour ne pas dire illimité (en terme d'etage dans l'arborescence) j'ai tout ce qu'il faut je viens de créer la fonction qui me manquait
je ferait un model version 2019 (ET SANS API !!!!!)

[patricktoulon]

bonjour 8Tnerolf8
voila un exemple pour positionner ton popup au niveau de ton control

dans la sub pour afficher le popup
exemple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
pos = position(label, Usf)
        CommandBars("MenuUSF").ShowPopup pos(1), pos(2)

la fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Function position(label As Object, Usf as Object )
    Dim PPX#, HcapTion#, LcaDre#, tbl(1 To 2)
    With ActiveWindow.ActivePane: PPX = (.PointsToScreenPixelsX(Cells.Width) - .PointsToScreenPixelsX(0)) / Cells.Width: End With
    HcapTion# = Usf.Height - Usf.InsideHeight
    LcaDre = Usf.Width - Usf.InsideWidth
    tbl(1) = (Usf.Left + LcaDre + label.Left) * PPX
    tbl(2) = (Usf.Top + HcapTion + label.Top + label.Height - LcaDre) * PPX
    position = tbl
End Function

voila aucune api il suffit de lui injecter le control et l'UserForm

[8Tnerolf8]

Bonjour patricktoulon

Si je souhaite privilégier les API, c'est dans l'optique de pouvoir potentiellement transposer cette fonctionnalité dans d'autres applications.

Or, si l'objet ActiveWindow.ActivePane existe bien pour Excel et Word, il n'en est rien concernant Access.

Je te remercie pour ta proposition, mais j'ai décidé de gérer différemment le problème du placement du menu, testé avec succès en Windows 7 et 10, comme suit :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Public Function RenvoieCoordEcran(Ctrl As Control, Optional PrendEnCpteHauteur As Boolean = True) As Double()
'Cette fonction renvoie les coordonnées du pixel située en haut et à gauche du contrôle Ctrl.
'Elle renvoie un tableau contenant en premier indice l'abscisse (x), en deuxième l'ordonnée (y), et en troisième l'abscisse correspondant à l'extrémité droite du contrôle.
'Si PrendEnCpteHauteur est Vrai, alors l'ordonnée sera celle du coin inférieur gauche du contrôle.
Dim DimCtrl As RECT, XX As Long, YY As Long, ZZ As Long, YiN As Long, HdC As Long, EpS As Long, lpppX As Long, lpppy As Long
Dim Coords(2) As Double, TareX As Single, TareY As Single
 
Static VersionWindows As String
 
If VersionWindows = vbNullString Then VersionWindows = GetWindowsVersion
 
ReDim RenvoieCoordEcran(1)
 
HdC = GetDC(0): lpppX = GetDeviceCaps(HdC, LOGPIXELSX): lpppy = GetDeviceCaps(HdC, LOGPIXELSY)
 
GetWindowRect GetActiveWindow, DimCtrl    ' coordonnées rectangle de l'userform
 
With Ctrl
    XX = .Left * lpppX / 72 'Position Gauche du contrôle cliqué en pixel
    YY = (.Top + IIf(PrendEnCpteHauteur, .Height, 0)) * lpppy / 72 'Position Haut du contrôle cliqué en pixel
    ZZ = (.Left + .Width) * lpppX / 72 'Position du bord droit du contrôle
 
    YiN = (.Parent.Height - .Parent.InsideHeight) * lpppy / 72  'Epaisseur de la caption du userform en pixel
    EpS = GetSystemMetrics(5) 'Epaisseur des bordures de l' userform en pixel
 
    'On détermine les tares de placements en fonction du Windows installé
    Select Case VersionWindows
        Case "Windows 7/Server 2008 R2"
            TareX = 2.4: TareY = -3.9
        Case "Windows 10"
            TareX = 5.6: TareY = -8.8
    End Select
 
    Coords(0) = DimCtrl.Left + EpS + XX + TareX
    Coords(1) = DimCtrl.Top + YiN + EpS + YY + TareY
    Coords(2) = DimCtrl.Left + EpS + ZZ + TareX
End With
 
RenvoieCoordEcran = Coords
End Function

Dans la fonction RenvoieCoordEcran, j'ai implémenté deux variables, TareX et TareY

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
'On détermine les tares de placements en fonction du Windows installé
    Select Case VersionWindows
        Case "Windows 7/Server 2008 R2"
            TareX = 2.4: TareY = -3.9
        Case "Windows 10"
            TareX = 5.6: TareY = -8.8
    End Select

C'est ici que l'on peut effectuer les réglages en fonction de la version de Windows.

Pour d'autre versions non répertoriées, il faut suivre la procédure suivante dans le module API :

- Mettre éventuellement à jour la fonction GetWindowsVersion si la version de Windows n'est pas répertoriée
- Mettre à jour le Select Case VersionWindows de la fonction RenvoieCoordEcran

[patricktoulon]

ok comme tu veux
juste par curiosité
que donne ceci dans acces

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
PtoPX= CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
msgbox PtoPX

[patricktoulon]

re

- Mettre éventuellement à jour la fonction GetWindowsVersion si la version de Windows n'est pas répertoriée
- Mettre à jour le Select Case VersionWindows de la fonction RenvoieCoordEcran

tu es loin du compte en fait il s'avere justement que c'est un sujet que j'ai traité de cette facon (windowversion) et la aussi ca a été un truc de fou

W7 et 2013,W7 et 2007,W7 et 2013 64bits pour ne citer que ces 3 exemples ne te donneront pas la même chose et c'est pareil pour toutes les versions Windows suivantes
et encore sans prendre en compte les différents paramétrage carte graphique qui entrent en ligne de compte aussi
je vais essayer de retrouver cette discussion, elle fut chargé tu peux me croire
sans parler des futures version Windows et d'office
ce sera un code a modifier tout le temps
par expériences je sais que coder des operateurs numériques en dur n'est pas une solution pérenne
WRONG WAY!!!!!
au pire honnêtement fait un simple showpopup sans coordonnées il s'affichera en top left du curseur

[8Tnerolf8]

Suite aux imprécations vindicatives de patricktoulon, j'ai revu la fonction RenvoieCoordEcran du module API de la façon suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Public Function RenvoieCoordEcran(Ctrl As Control, Optional PrendEnCpteHauteur As Boolean = True) As Double()
'Cette fonction renvoie les coordonnées de pixels situés aux coins du contrôle Ctrl.
'Elle renvoie un tableau contenant en premier indice l'abscisse (x), en deuxième l'ordonnée (y), et en troisième l'abscisse correspondant à l'extrémité droite du contrôle.
'Si PrendEnCpteHauteur est Vrai, alors l'ordonnée sera celle du coin inférieur gauche du contrôle.
Dim DimForm As RECT, Abscisse As Long, Ordonnee As Long, AbscisseDroite As Long, HandleBureau As Long, EpaisseurX As Long, EpaisseurY As Long, _
Coords(2) As Double, Pt2Px As Double
 
'https://www.ninjaunits.com/converters/pixels/points-pixels/
'How many Pixels are in a Point? : 1 pt = 1.333(3) px
'How many Points are in a Pixel? : 1 px = 0.75 pt
Pt2Px = 1 + (1 / 3)
 
'GetDC(0) : Private Const HWND_DESKTOP As Long = 0
'https://docs.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-getdc
'The GetDC function retrieves a handle to a device context (DC) for the client area of a specified window or for the entire screen.
HandleBureau = GetDC(0)
 
GetWindowRect GetActiveWindow, DimForm 'Coordonnées rectangle du formulaire contenant le contrôle en Pixels
 
With Ctrl
    EpaisseurX = (.Parent.Width - .Parent.InsideWidth) / 2 'Epaisseur de la bordure verticale. / 2 car il y a 2 bordures (gauche et droite)
    EpaisseurY = (.Parent.Height - .Parent.InsideHeight) - EpaisseurX 'Epaisseur de la bordure horizontale
    'Le - EpaisseurX correspond à la hauteur de la bordure du bas qui possède la même épaisseur que celles des côtés
 
    Abscisse = .Left  'Position Gauche du contrôle cliqué
    Ordonnee = .Top + IIf(PrendEnCpteHauteur, .Height, 0) 'Position Haut du contrôle cliqué
    AbscisseDroite = .Left + .Width 'Position du bord droit du contrôle
 
    Coords(0) = DimForm.Left + (EpaisseurX + Abscisse) * Pt2Px
    Coords(1) = DimForm.Top + (EpaisseurY + Ordonnee) * Pt2Px
    Coords(2) = DimForm.Left + (EpaisseurX + AbscisseDroite) * Pt2Px
End With
 
RenvoieCoordEcran = Coords
End Function

[patricktoulon]

re
Bonjour 8Tnerolf8
c'est toujours pareil c'est l'équivalent de 4/3
et ca ne fonctionnera pas chez moi par exemple qui suis en DPI 120 et non en 96 soit un coeff de 1.6666666666666 et non 1.333333333333333 ou *0.75

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Pt2Px = 1 + (1 / 3)

fait le avec wscript.shell et on en parle plus
je dis ca moi ,après je t'oblige a rien ,prévient seulement en commentaire "adapter le coeff reel du pc de l'utilisateur" mais c'est dommage que l'on soit obligé d'aller retoucher le code d'une source
tu a fait un boulot de fou et tu bloque sur cette broutille

[8Tnerolf8]

re
chez moi par exemple qui suis en DPI 120 et non en 96 soit un coeff de 1.6666666666666 et non 1.333333333333333 ou *0.75

Un grand merci à patricktoulon qui, sans le vouloir, m'a apporté la solution.

Il suffit de faire un Ratio
How many Pixels are in a Point? : 1 pt = 1.333(3) px => Pour 96 DPI

Donc, pour 120 DPI, Pt2Px se calcule comme suit :
1,333333333333333 / 96 * 120 = 1,666666666666666

[patricktoulon]

re
bonjour
oui ok
et comment la macro va décider d'appliquer une règle ou une autre
c'est du hardcodage que tu fait la
et pour info tu a plusieurs réglage utilisés autre que 96 et 120

non de dieu !
ceci ci dessous te donnera automatiquement!!!!! chez toi 1.333.... et chez moi 1.666... et chez d'autre 1.xxx...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Option Compare Database
Function PtoPX() As Double
PtoPX = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
End Function
'
Sub test()
MsgBox PtoPX
End Sub

et j'ai testé dans acces
tu es dur en affaire toi hein

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
pos = position(lecontrol, UserForm)
CommandBars("MenuUSF").ShowPopup pos(1), pos(2)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Function position(label As Object, Usf)
    Dim PPX#, HcapTion#, LcaDre#, tbl(1 To 2)
    PPX = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72
    LcaDre = Usf.Width - Usf.InsideWidth
    tbl(1) = (Usf.Left + LcaDre + label.Left) * PPX
    tbl(2) = (Usf.Top + HcapTion + label.Top + label.Height - LcaDre) * PPX
    position = tbl
End Function

et ca marche dans acces aussi
enfin bref tu pourra pas dire que je t'ai pas picoté si tu ne veux pas ben... tu veux pas

[8Tnerolf8]

Ta méthode donne exactement les mêmes résultats que la mienne.

En effet, je fais un ratio entre une conversion connue et le nombre de DPI utilisé sur le poste de l'utilisateur.

Donc, il sera déterminé toujours le bon nombre de 1.xxx