如何将macros指定给自定义菜单VBA？

我试图创build一个自定义菜单与button，macros分配给他们，使最终用户不需要做任何事情，除了运行它。 我有安装程序作为附加和ThisWorkbook中的代码将运行在打开的事件一切运行完美，但问题是button不工作，除了RemoveButtons，完全删除添加。 也许我在这里做错了什么。 代码在标准模块中。

Private Sub AddButtons() Const MyControl As String = "Applications..." Const MyControlCaption As String = "Manage Applications" Dim AddinTitle As String, Mybar As Object AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) Call RemoveButtons On Error GoTo ErrHandler Set Mybar = Application.CommandBars("Worksheet Menu Bar") _ .Controls("Tools").Controls _ .Add(Type:=msoControlPopup, before:=13) With Mybar .BeginGroup = True .Caption = MyControl '------------------------------------------------------------- .Controls.Add.Caption = MyControlCaption .Controls(MyControlCaption).OnAction = "ShowStartupForm" '------------------------------------------------------------- With .Controls.Add(Type:=msoControlButton) .BeginGroup = True .Caption = "About " & AddinTitle End With .Controls("About " & AddinTitle).OnAction = "ShowAboutForm" '------------------------------------------------------------- .Controls.Add.Caption = "Remove " & AddinTitle .Controls("Remove " & AddinTitle).OnAction = "RemoveAddIn" .Controls.Add.Caption = "Edit " & AddinTitle .Controls("Edit " & AddinTitle).OnAction = "EditSheets" '------------------------------------------------------------- End With Exit Sub ErrHandler: Set Mybar = Nothing Set Mybar = Application.CommandBars("Tools") _ .Controls.Add(Type:=msoControlPopup, before:=13) Resume Next End Sub Private Sub RemoveButtons() Const MyControl As String = "Applications..." On Error Resume Next With Application .CommandBars("Tools").Controls(MyControl).Delete .CommandBars("Worksheet Menu Bar") _ .Controls("Tools").Controls(MyControl).Delete End With End Sub 

Answer 1

我告诉你我正在使用的代码的一个例子，你可以使用你需要的位…这是一个右键clic的缩短版本：

 Option Explicit Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Dim MySubMenu As CommandBarControl Cancel = True With Application .ScreenUpdating = False .EnableEvents = False '.Calculation = xlCalculationManual 'cuts copy End With Application.CommandBars("Cell").Reset Set MySubMenu = Application.CommandBars("Cell").Controls.add(Type:=msoControlPopup, before:=1) With MySubMenu .Caption = "Heroes && Beasts" .Tag = "Hefffffsts" With .Controls.add(Type:=msoControlButton) .Caption = "Importer l'Objet vers l'Inventaire Global." .FaceId = 51 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Vers_Inventaire_show" '"Vers_INV" End With With .Controls.add(Type:=msoControlButton) .Caption = "Importer l'Objet vers le Fichier Marchand/Vendeur." .FaceId = 52 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Vers_Marchand" End With With .Controls.add(Type:=msoControlButton) .Caption = "Corriger Taille Ligne (Autofit + //Image)." .FaceId = 164 '338 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Set_Row_Height_To_Pic" .BeginGroup = True End With With .Controls.add(Type:=msoControlButton) .Caption = "Vérifier doublons de noms et recentrer toutes les images." .FaceId = 620 '550 '735 '999 '995 .OnAction = "'" & ThisWorkbook.Name & "'!" & "sheet_deactiv_public" End With With .Controls.add(Type:=msoControlButton) .Caption = "Mettre à jour le Format des Cellules de la Page." .FaceId = 791 '962 '661 ' 513 ' 439 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Verif_Format_Page2" End With With .Controls.add(Type:=msoControlButton, before:=1 + trouve_pos(22, "Paste")) .Caption = "Insérer Ligne (par le dessus)." .FaceId = 15 .OnAction = "'" & ThisWorkbook.Name & "'!'InsertLine_Menu_deroulant'" End With With .Controls.add(Type:=msoControlButton) ', before:=,) .Caption = "Afficher l'Interface." .OnAction = "'" & ThisWorkbook.Name & "'!'Interface_Show2'" .FaceId = 642 '343'611 End With End With With .Controls.add(Type:=msoControlButton) .Caption = "Refaire icones d'objets du menu déroulant." .FaceId = 734 '962 '703 '965 '558 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Memoriser_Objets" End With With .Controls.add(Type:=msoControlButton) .Caption = "Vérifier si il ya des Images trop Grandes." .FaceId = 990 '273 '642 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Verif_Tailles_Images" End With With .Controls.add(Type:=msoControlButton) .Caption = "Classer les objets par Rang (+0 à +6) - (Béta v3)" .TooltipText = "Ne traite pas (encore) le classement par prix" .FaceId = 11 '304 .OnAction = "'" & ThisWorkbook.Name & "'!" & "Ranger_Lignes_Par_Rang" End With With .Controls.add(Type:=msoControlButton) .Caption = "Classer les objets par Prix (Béta v1)" .FaceId = 304 .TooltipText = "Le classement par Rang DOIT déjà être fait avant." .OnAction = "'" & ThisWorkbook.Name & "'!" & "Trier_Page_par_prix" End With With .Controls.add(Type:=msoControlButton) .Caption = "Classer les objets par Rang, et Prix" .FaceId = 451 ' 658 ' 703 '.TooltipText = "Le classement par Rang DOIT déjà être fait avant." .OnAction = "'" & ThisWorkbook.Name & "'!" & "Trier_Page_par_rang_et_prix" End With End With With Application .EnableEvents = True .ScreenUpdating = True .CommandBars("Cell").ShowPopup End With Application.CommandBars("Cell").Reset Set MySubMenu = Nothing End Sub 

你的一些编码是非常令人迷惑的。

每次使用.controls.add ，你都应该把它放在一个variables中（通过使用set XXX= …），或者使用。

Answer 2

转到选项。 单击信任中心，然后单击信任中心设置。 在信任中心中，单击macros设置。 然后select“启用所有macros”