Logit
07-12-2018, 08:18 AM
.
Here is a sample UserForm Menu. It display the menu constantly but hopefully it is something you can use :
Option Base 1
Option Explicit
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private xOffset As Single
Private yOffset As Single
Private Sub DisplayPopUp(ByVal idx As Byte)
Application.CommandBars("PopUpCb" & idx).ShowPopup xPos(idx), yPos
End Sub
Private Sub Button_U1_Click()
Call Menus_CheckBox(True)
End Sub
Private Sub Menus_CheckBox(Coché As Boolean)
Dim Ctl As Control
For Each Ctl In Me.Controls
If Left(Ctl.Name, 8) = "CheckBox" Then Ctl.Value = Coché
Next Ctl
End Sub
Private Sub ComboBox1_Change()
With ComboBox1
If .ListIndex = 0 Then [a1] = "un machin"
If .ListIndex = 1 Then [a1] = "un bidule"
If .ListIndex = 2 Then [a1] = "une chouette"
End With
End Sub
Private Sub lbl1_Click()
Call lblStyle(2, "1000")
DisplayPopUp 1
End Sub
Private Sub lbl1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "1000")
Call lblStyle(0, "1000")
End Sub
Private Sub lbl2_Click()
Call lblStyle(2, "0100")
DisplayPopUp 2
End Sub
Private Sub lbl2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "0100")
Call lblStyle(0, "0100")
End Sub
Private Sub lbl3_Click()
Call lblStyle(2, "0010")
DisplayPopUp 3
End Sub
Private Sub lbl3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "0010")
Call lblStyle(0, "0010")
End Sub
Private Sub lbl4_Click()
Call lblStyle(2, "0001")
DisplayPopUp 4
End Sub
Private Sub lbl4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'Call lblStyle(3, "0001")
Call lblStyle(0, "0001")
End Sub
' 0-Flat / 1-Raised / 2-Sunken / 3-Etched
Sub lblStyle(look As Byte, Optional Info As String = "0000")
Dim i As Byte
For i = 1 To Len(Info)
If Mid(Info, i, 1) = 0 Then
Me.Controls("lbl" & i).Font.Bold = False
Me.Controls("lbl" & i).SpecialEffect = 0
Else
Me.Controls("lbl" & i).Font.Bold = True
Me.Controls("lbl" & i).SpecialEffect = look
End If
Next i
End Sub
Sub CreatePopUp(ByVal idx As Integer)
' CbPopUp() = niveaux d'imbrication
Dim cb As CommandBar, CbPopup(2) As CommandBarPopup, noMenu As String
Call DeletePopUp("PopUpCb" & idx)
noMenu = "'MacroName""" & idx
Set cb = CommandBars.Add("PopUpCb" & idx, msoBarPopup, False, True)
Select Case idx
Case 1
Call AddItemInMenu(cb, Range("a1").Value, 212, noMenu & "01""'")
Call AddItemInMenu(cb, "&Sauvegarder", 3, noMenu & "02""'")
Call AddItemInMenu(cb, "&Quitter", 1, noMenu & "03""'", True)
Case 2
Call AddItemInMenu(cb, "&Nouvelle", 18, noMenu & "01""'")
Call AddItemInMenu(cb, "&Existante", 23, noMenu & "02""'")
Call AddItemInMenu(cb, "&Réceptions", 109, noMenu & "03""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "Ed&itions"
CbPopup(1).BeginGroup = True
Call AddItemInMenu(CbPopup(1), "Cdes à &relancer", 4, noMenu & "04""'")
Call AddItemInMenu(CbPopup(1), "Cdes non &soldées", 4, noMenu & "05""'")
Call AddItemInMenu(cb, "&Total Achats", 283, noMenu & "06""'", True)
Call AddItemInMenu(cb, "A&purement", 67, noMenu & "07""'")
Case 3
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "A&rticles"
Call AddItemInMenu(CbPopup(1), "Fic&hes", 212, noMenu & "01""'")
Call AddItemInMenu(CbPopup(1), "&Utilisations", 140, noMenu & "02""'")
Call AddItemInMenu(CbPopup(1), "&Remplacement", 564, noMenu & "03""'")
Call AddItemInMenu(CbPopup(1), "&Liste des...", 4, noMenu & "04""'")
Call AddItemInMenu(CbPopup(1), "Calcul des c&oûts", 283, noMenu & "05""'")
Set CbPopup(2) = CbPopup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(2).Caption = "Fa&milles"
CbPopup(2).BeginGroup = True
Call AddItemInMenu(CbPopup(2), "&Fiches", 212, noMenu & "06""'")
Call AddItemInMenu(CbPopup(2), "Li&ste des...", 4, noMenu & "07""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "&Fournisseurs"
Call AddItemInMenu(CbPopup(1), "Fic&hes", 212, noMenu & "08""'")
Call AddItemInMenu(CbPopup(1), "Liste &des...", 4, noMenu & "09""'")
Call AddItemInMenu(CbPopup(1), "&Qualité...", 4, noMenu & "10""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "Four&nitures"
Call AddItemInMenu(CbPopup(1), "F&iches", 212, noMenu & "11""'")
Call AddItemInMenu(CbPopup(1), "Lis&te des...", 4, noMenu & "12""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "&Nomenclatures"
Call AddItemInMenu(CbPopup(1), "Co&nsultation", 109, noMenu & "13""'")
Call AddItemInMenu(CbPopup(1), "&Modif / Création / Sup.", 212, noMenu & "14""'")
Call AddItemInMenu(CbPopup(1), "&Historique modifs", 172, noMenu & "15""'")
Call AddItemInMenu(CbPopup(1), "&Import CAO", 524, noMenu & "16""'")
Call AddItemInMenu(CbPopup(1), "&Export CAO", 525, noMenu & "17""'")
Set CbPopup(2) = CbPopup(1).Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(2).Caption = "Editi&ons"
CbPopup(2).BeginGroup = True
Call AddItemInMenu(CbPopup(2), "&Quantifiée", 4, noMenu & "18""'")
Call AddItemInMenu(CbPopup(2), "Cumu&lée", 4, noMenu & "19""'")
Call AddItemInMenu(CbPopup(2), "Arbore&scente", 4, noMenu & "20""'")
Call AddItemInMenu(CbPopup(2), "&Liste des...", 4, noMenu & "21""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "&Données"
Call AddItemInMenu(CbPopup(1), "Cours des de&vises", 283, noMenu & "22""'")
Call AddItemInMenu(CbPopup(1), "&Imputations comptables", 195, noMenu & "23""'")
Call AddItemInMenu(CbPopup(1), "Im&putations analytiques", 303, noMenu & "24""'")
Call AddItemInMenu(CbPopup(1), "&Unités de mesure", 548, noMenu & "25""'")
Call AddItemInMenu(CbPopup(1), "&Conditions paiement", 384, noMenu & "26""'")
Call AddItemInMenu(CbPopup(1), "Coe&ff. Prix vente", 50, noMenu & "27""'")
Set CbPopup(1) = cb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
CbPopup(1).Caption = "Stoc&ks"
Call AddItemInMenu(CbPopup(1), "&Entrées / Sorties", 212, noMenu & "28""'")
Call AddItemInMenu(CbPopup(1), "&Historique Trs", 172, noMenu & "29""'")
Case 4
Call AddItemInMenu(cb, "A&ide", 983, noMenu & "01""'")
Call AddItemInMenu(cb, "A pr&opos", 487, noMenu & "02""'")
End Select
Set CbPopup(1) = Nothing: Set CbPopup(2) = Nothing: Set cb = Nothing
End Sub
Private Function xPos(ByVal nb As Byte) As Single
xPos = (Me.Left + xOffset + Me.Controls("lbl" & nb).Left) * 4 / 3
End Function
Private Function yPos() As Single
yPos = (Me.Top + yOffset) * 4 / 3
End Function
Private Sub AddItemInMenu(CbControl As Object, TitleCaption As String, NoFaceId As Integer, WhenAction As String, Optional NewGroup As Boolean = False)
With CbControl.Controls.Add(msoControlButton, 1, , , True)
.BeginGroup = NewGroup
.Caption = TitleCaption
.Style = msoButtonIconAndCaption
.FaceId = NoFaceId
.OnAction = ThisWorkbook.Name & "!" & WhenAction & ""
End With
End Sub
Private Sub DeletePopUp(ByVal PopUpCbName As String)
On Error Resume Next
CommandBars(PopUpCbName).Delete
End Sub
Private Sub UserForm_Activate()
ComboBox1.AddItem "machin"
ComboBox1.AddItem "bidule"
ComboBox1.AddItem "chouette"
End Sub
Private Sub UserForm_Initialize()
Const pLbl As Byte = 3 ' Top des labels Menus
Const hLbl As Byte = 14 ' Hauteur des labels Menus
Dim i As Byte
For i = 1 To 4
Me.Controls("lbl" & i).Height = hLbl
Me.Controls("lbl" & i).Top = pLbl
Call CreatePopUp(i)
Next i
xOffset = (Me.Width - Me.InsideWidth) / 2
yOffset = Me.Height - Me.InsideHeight - xOffset + hLbl + pLbl
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call lblStyle(0, "0000")
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.