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