Téléchargé 31 fois

Vote des utilisateurs

Voir les 28 commentaires

Détails

Éditeur : Florent Bénetière

Licence : Freeware

Mise en ligne le 17 mai 2019

Langue : Français

Référencé dans

Codes sources VBA Excel

Navigation

Retourner à la liste des ressources Retourner à l'accueil des téléchargements Ajouter un LOGICIELAjouter un FRAMEWORKAjouter un CODE SOURCE

Insertion de menus dynamiques dans un formulaire Excel ou un document Word

En me basant sur les travaux de Michel Pierron trouvés dans un classeur sur https://www.developpez.net/forums/d779626/logiciels/microsoft-office/excel/macros-vba-excel/menubar-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

Signaler un problème

patricktoulon

Inactif

Le 13/05/2019 à 11:01

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

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

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

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

sinon tu a l' api gdi"GetDeviceCaps"
voila

patricktoulon

Inactif

Le 08/05/2019 à 23:31

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

Inactif

Le 11/05/2019 à 8:37

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

galopin01

Membre actif

Le 12/05/2019 à 14:07

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

Merci.

8Tnerolf8

Membre du Club

Le 13/05/2019 à 8:14

Envoyé par galopin01

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

Membre du Club

Le 13/05/2019 à 8:20

Envoyé par patricktoulon

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 ?

8Tnerolf8

Membre du Club

Le 13/05/2019 à 12:05

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/d1656328/logiciels/microsoft-office/excel/contribuez/toolbar-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

Inactif

Le 13/05/2019 à 12:33

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

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

Membre du Club

Le 13/05/2019 à 14:44

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/d1656328/logiciels/microsoft-office/excel/contribuez/toolbar-userform/)

Code :

Sélectionner tout

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

Consultez l'ensemble des 28 commentaires

Poster un commentaire

Developpez.com décline toute responsabilité quant à l'utilisation des différents éléments téléchargés.