VBA/Excel/Access/Word/Application/Menu
Содержание
- 1 Add a new menubar with toggle action
- 2 Adding a menu selection that features a shortcut key
- 3 Adding a menu: Take 1
- 4 Adding and deleting menus automatically
- 5 Adding a new item to the Cell shortcut menu
- 6 Adding a selection to Excel"s Tools menu
- 7 Adding menu items to shortcut menus
- 8 Adding selections and submenu items to the Budgeting menu
- 9 Adding the Budgeting menu to Excel"s main menu bar
- 10 Adds button, combobox, text box and drop down to tools menu
- 11 Controling a CommandBarControl"s Visibility
- 12 Create a new menu bar that replaces the existing menu bar
- 13 Create a popup menu
- 14 Create Submenus
- 15 Creating a Menu Bar
- 16 Creating an entirely new and separate shortcut menu
- 17 Deletes a control tagged "MyMenu2"
- 18 Deleting a menu from a menu bar
- 19 Deleting a menu item from the Tools menu
- 20 Deleting menu items from shortcut menus
- 21 Determined the Id property of the Help menu by executing the following statement:
- 22 Disabling a shortcut menu
- 23 Disabling or hiding menus
- 24 Disabling shortcut menu items
- 25 Disabling shortcut menus
- 26 Enables the shortcut menu when the workbook is closed.
- 27 If you want to disable all shortcut menus, use the following procedure:
- 28 List Menu Information
- 29 List ShortCut Menus
- 30 removes the Hide menu item from two shortcut menus: the one that appears when you right-click a row header and the one that appears for a column header.
- 31 Resetting shortcut menus: The Reset method restores a shortcut menu to its original condition.
- 32 Working with checked menu items
<source lang="vb">
Sub AddNewMB()
Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl Dim myCommandBarSubCtl As CommandBarControl On Error GoTo AddNewMB_Err Set myCommandBar = CommandBars.Add(Name:="Sample Menu Bar", Position:=msoBarTop, menuBar:=True, Temporary:=False) myCommandBar.Visible = True myCommandBar.Protection = msoBarNoMove Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlPopup) myCommandBarCtl.Caption = "Displa&y" Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton) With myCommandBarSubCtl .Style = msoButtonIconAndCaption .Caption = "E&nable ClickMe" .FaceId = 59 .OnAction = "=ToggleClickMe()" .Parameter = 1 .BeginGroup = True End With Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton) With myCommandBarSubCtl .Style = msoButtonIconAndCaption .Caption = "Di&sable ClickMe" .FaceId = 276 .OnAction = "=ToggleClickMe()" .Parameter = 2 .BeginGroup = True End With Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton) With myCommandBarCtl .BeginGroup = True .Caption = "&ClickMe" .Style = msoButtonCaption .OnAction = "=MsgBox(""You clicked ClickMe"")" End With Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton) With myCommandBarCtl .BeginGroup = True .Caption = "&Set Visibility Off" .Style = msoButtonCaption .OnAction = "=SampleMenuDisable()" End With Exit Sub
AddNewMB_Err:
Debug.Print Err.number & vbCr & Err.Description Exit Sub
End Sub Function ToggleClickMe()
Dim MyMenu As CommandBar Dim myCommandBarClickMe As CommandBarControl On Error GoTo ToggleClickMe_Err Set MyMenu = CommandBars("Sample Menu Bar") Set myCommandBarClickMe = MyMenu.Controls(2) With CommandBars.ActionControl Select Case .Parameter Case 1 myCommandBarClickMe.Enabled = True Case 2 myCommandBarClickMe.Enabled = False End Select End With Exit Function
ToggleClickMe_Err:
Debug.Print Err.number & vbCr & Err.Description Exit Function
End Function Function SampleMenuDisable()
Application.rumandBars("Sample Menu Bar").Visible = False Application.rumandBars("Menu Bar").Visible = True
End Function
</source>
<source lang="vb">
Sub AddMenuItem()
Dim ToolsMenu As CommandBarPopup Dim NewMenuItem As CommandBarButton Call DeleteMenuItem Set ToolsMenu = CommandBars(1).FindControl(Id:=30007) If ToolsMenu Is Nothing Then MsgBox "Cannot add a menu item - use Ctrl+Shift+C." Exit Sub Else Set NewMenuItem = ToolsMenu.Controls.Add _ (Type:=msoControlButton) With NewMenuItem .Caption = "&yourCaption" .FaceId = 348 .ShortcutText = "Ctrl+Shift+C" .OnAction = "yourAction" .BeginGroup = True End With End If Application.MacroOptions Macro:="yourMacro",HasShortcutKey:=True,ShortcutKey:="C"
End Sub
</source>
<source lang="vb">
Sub AddNewMenu()
HelpIndex = CommandBars(1).Controls("Help").Index Set NewMenu = CommandBars(1).Controls.Add _ (Type:=msoControlPopup, _ Before:=HelpIndex, _ Temporary:=True) NewMenu.Caption = "&vbex"
End Sub
</source>
<source lang="vb">
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not Me.Saved Then Msg = "Do you want to save the changes you made to " Msg = Msg & Me.Name & "?" Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel) Select Case Ans Case vbYes Me.Save Case vbNo Me.Saved = True Case vbCancel Cancel = True Exit Sub End Select End If Call DeleteMenu
End Sub
</source>
<source lang="vb">
Sub AddToShortCut()
Dim Bar As CommandBar Dim NewControl As CommandBarButton DeleteFromShortcut Set Bar = Application.rumandBars("Cell") Set NewControl = Bar.Controls.Add(Type:=msoControlButton, ID:=1,temporary:=True) With NewControl .Caption = "&Change Case" .OnAction = "ChangeCase" .Style = msoButtonIconAndCaption End With
End Sub
</source>
<source lang="vb">
Sub AddMenuItem()
Dim ToolsMenu As CommandBarPopup Dim NewMenuItem As CommandBarButton Set ToolsMenu = CommandBars(1).FindControl(Id:=30007) If ToolsMenu Is Nothing Then MsgBox "Cannot add menu item." Exit Sub Else Set NewMenuItem = ToolsMenu.Controls.Add _ (Type:=msoControlButton) With NewMenuItem .Caption = "&Clear" .FaceId = 348 .OnAction = "yourAction" .BeginGroup = True End With End If
End Sub
</source>
<source lang="vb">
Sub AddItemToShortcut()
Set NewItem = CommandBars("Cell").Controls.Add With NewItem .Caption = "Toggle Word Wrap" .OnAction = "ToggleWordWrap" .BeginGroup = True End With
End Sub
</source>
<source lang="vb">
Sub CreateMenu()
Dim HelpMenu As CommandBarControl Dim NewMenu As CommandBarPopup Set HelpMenu = CommandBars(1).FindControl(ID:=30010) If HelpMenu Is Nothing Then Set NewMenu = CommandBars(1).Controls _ .Add(Type:=msoControlPopup, temporary:=True) Else Set NewMenu = CommandBars(1).Controls _ .Add(Type:=msoControlPopup, Before:=HelpMenu.Index, _ temporary:=True) End If NewMenu.Caption = "&ItemMenu" Set MenuItem = NewMenu.Controls.Add _ (Type:=msoControlButton) With MenuItem .Caption = "&Item1..." .FaceId = 162 .OnAction = "Macro1" End With Set MenuItem = NewMenu.Controls.Add _ (Type:=msoControlButton) With MenuItem .Caption = "&Item2..." .FaceId = 590 .OnAction = "Macro2" End With Set MenuItem = NewMenu.Controls.Add _ (Type:=msoControlPopup) With MenuItem .Caption = "Item &Charts" .BeginGroup = True End With Set SubMenuItem = MenuItem.Controls.Add _ (Type:=msoControlButton) With SubMenuItem .Caption = "Item &Variance" .FaceId = 420 .OnAction = "Macro3" End With Set SubMenuItem = MenuItem.Controls.Add _ (Type:=msoControlButton) With SubMenuItem .Caption = "&Summary" .FaceId = 422 .OnAction = "Macro4" End With
End Sub
</source>
<source lang="vb">
Sub AddNewMenu()
Dim HelpMenu As CommandBarControl Dim NewMenu As CommandBarPopup Set HelpMenu = CommandBars(1).FindControl(ID:=30010) If HelpMenu Is Nothing Then Set NewMenu = CommandBars(1).Controls _ .Add(Type:=msoControlPopup, Temporary:=True) Else Set NewMenu = CommandBars(1).Controls _ .Add(Type:=msoControlPopup, Before:=HelpMenu.Index, _ Temporary:=True) End If NewMenu.Caption = "&newCommand"
End Sub
</source>
<source lang="vb">
Sub ExpandMenu()
Dim cbc As CommandBarControl Dim cbb As CommandBarButton Dim cbcm As CommandBarComboBox Dim cbp As CommandBarPopup With Application.rumandBars("Worksheet Menu Bar").Controls("tools") Set cbc = .Controls.Add(Id:=3, Temporary:=True) Set cbb = .Controls.Add(Temporary:=True) cbb.Caption = "A new command" cbb.Style = msoButtonCaption cbb.OnAction = "NewCommand_OnAction" Set cbcm = .Controls.Add(Type:=msoControlComboBox, Temporary:=True) cbcm.Caption = "Combo:" cbcm.AddItem "list entry 1" cbcm.AddItem "list entry 2" cbcm.OnAction = "NewCommand_OnAction" cbcm.Style = msoComboLabel Set cbc = .Controls.Add(Type:=msoControlEdit, Temporary:=True) cbc.Caption = "Text box:" cbc.Text = "Type in a text:" cbc.OnAction = "MenuText_OnAction" Set cbc = .Controls.Add(Type:=msoControlDropdown, Temporary:=True) cbc.Caption = "Dropdown:" cbc.AddItem "list entry 1" cbc.AddItem "list entry 2" cbc.OnAction = "MenuDropdown_OnAction" Set cbp = .Controls.Add(Type:=msoControlPopup, Temporary:=True) cbp.Caption = "new sub menu" Set cbb = cbp.Controls.Add cbb.Caption = "sub entry 1" Set cbb = cbp.Controls.Add cbb.Caption = "sub entry 2" End With
End Sub Sub MenuCombo_OnAction()
MsgBox "Selected list entry: " & _ CommandBars("Worksheet Menu Bar").Controls("tools").Controls("Combo:").Text
End Sub Sub MenuText_OnAction()
MsgBox "New text: " & _ CommandBars("Worksheet Menu Bar").Controls("tools").Controls("Text box:").Text
End Sub Sub MenuDropdown_OnAction()
MsgBox "Selected list entry: " & _ CommandBars("Worksheet Menu Bar").Controls("tools").Controls("Dropdown:").Text
End Sub
</source>
Controling a CommandBarControl"s Visibility
<source lang="vb">
Sub SetVisibilityExample()
SetControlVisibility "MyMenu", True SetControlVisibility "MyMenu", False
End Sub Sub SetControlVisibility(sTag As String, IsVisible As Boolean)
Dim cbc As CommandBarControl Set cbc = Application.rumandBars.FindControl(, , sTag) If Not cbc Is Nothing Then cbc.Visible = IsVisible End If Set cbc = Nothing
End Sub
</source>
<source lang="vb">
Private myMenu As CommandBar Private subControl1 As CommandBarButton Public Sub NewMenu()
Dim myControl1 As CommandBarControl Dim subControl1 As CommandBarControl Set myMenu = Application.rumandBars.Add( _ name:=" My Menu Bar", _ Position:=msoBarTop, _ MenuBar:=True, _ Temporary:=True) myMenu.Visible = True Set myControl1 = myMenu.Controls.Add( _ Type:=msoControlPopup, _ ID:=1, _ Before:=1, _ Temporary:=True) myControl1.Caption = "Menu Header &1" Set subControl1 = myControl1.Controls.Add( _ ID:=1, _ Parameter:=" You have chosen to delete the custom menu!", _ Before:=1, _ Temporary:=True) subControl1.Caption = "Delete Menu" subControl1.Visible = True subControl1.OnAction = "DeleteMenu"
End Sub Private Sub DeleteMenu()
MsgBox subControl1.Parameter myMenu.Delete
End Sub
</source>
<source lang="vb">
Sub CreatePopup()
Dim cbpop As CommandBarControl Dim cbctl As CommandBarControl Dim cbsub As CommandBarControl Set cbpop = Application.rumandBars("Worksheet Menu Bar"). _ Controls.Add(Type:=msoControlPopup) cbpop.Caption = "&Custom" cbpop.Visible = True Set cbctl = cbpop.Controls.Add(Type:=msoControlButton) cbctl.Visible = True cbctl.Style = msoButtonCaption cbctl.Caption = "MenuItem&1" cbctl.OnAction = "ExampleMacro1" Set cbsub = cbpop.Controls.Add(Type:=msoControlPopup) cbsub.Visible = True cbsub.Caption = "&SubMenuItem1" Set cbctl = cbsub.Controls.Add(Type:=msoControlButton) cbctl.Visible = True cbctl.Style = msoButtonCaption cbctl.Caption = "SubMenuItem&2" cbctl.OnAction = "ExampleMacro2"
End Sub
</source>
<source lang="vb">
Public Sub newSubMenu()
Dim menuBar As CommandBar Dim newMenu As CommandBarControl Dim menuItem As CommandBarControl Dim subMenuItem As CommandBarControl Set menuBar = CommandBars.Add(menuBar:=True, Position:=msoBarTop, Name:="Sub Menu Bar", Temporary:=True) menuBar.Visible = True Set newMenu = menuBar.Controls.Add(Type:=msoControlPopup) newMenu.Caption = "&First Menu" Set newMenu = menuBar.Controls.Add(Type:=msoControlPopup) newMenu.Caption = "&Second Menu" Set newMenu = menuBar.Controls.Add(Type:=msoControlPopup) newMenu.Caption = "&Third Menu" Set menuItem = newMenu.Controls.Add(Type:=msoControlButton) With menuItem .Caption = "F&irst Sub" .FaceId = "356" .OnAction = "myTest" End With Set menuItem = newMenu.Controls.Add(Type:=msoControlButton) With menuItem .Caption = "S&econd Sub" .FaceId = "333" .OnAction = "otherTest" End With Set menuItem = newMenu.Controls.Add(Type:=msoControlPopup) menuItem.Caption = "Sub Menus" Set subMenuItem = menuItem.Controls.Add(Type:=msoControlButton) With subMenuItem .Caption = "Item 1" .FaceId = 321 .OnAction = "firstMacro" End With Set subMenuItem = menuItem.Controls.Add(Type:=msoControlButton) With subMenuItem .Caption = "Item 2" .FaceId = 432 .OnAction = "secondMacro" End With
End Sub
</source>
Creating a Menu Bar
<source lang="vb">
Public Sub AddMenuItemExample()
Dim cbWSMenuBar As CommandBar Dim cbc As CommandBarControl Set cbWSMenuBar = Application.rumandBars("Worksheet Menu Bar") Set cbc = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True) cbc.Tag = "MyMenu" With cbc .Caption = "&My Menu" With .Controls.Add(Type:=msoControlButton, Temporary:=True) .Caption = "Item &1" .OnAction = "ThisWorkbook.SayHello" .Tag = "Item1" End With With .Controls.Add(Type:=msoControlButton, Temporary:=True) .Caption = "Item &2" .OnAction = "ThisWorkbook.SayHello" .Tag = "Item2" End With With .Controls.Add(Type:=msoControlButton, Temporary:=True) .Caption = "Item &3" .OnAction = "ThisWorkbook.SayHello" .Tag = "Item 3" End With With .Controls.Add(Type:=msoControlButton, Temporary:=True) .Caption = "Item &4" .OnAction = "ThisWorkbook.SayHello" .BeginGroup = True .Tag = "Item4" End With With .Controls.Add(Type:=msoControlButton, Temporary:=True) .Caption = "Item &5" .OnAction = "ThisWorkbook.SayHello" .Tag = "Item5" .BeginGroup = True End With With .Controls.Add(Type:=msoControlButton, Temporary:=True) .Caption = "Item &6" .OnAction = "ThisWorkbook.SayHello" .Tag = "Item6" End With End With
End Sub Private Sub SayHello()
MsgBox "Hello", vbOKOnly
End Sub
</source>
<source lang="vb">
Sub CreateShortcut()
Set myBar = CommandBars.Add _ (name:="MyShortcut", Position:=msoBarPopup, _ Temporary:=True) Set myItem = myBar.Controls.Add(Type:=msoControlButton) With myItem .Caption = "&Number Format..." .OnAction = "ShowFormatNumber" .FaceId = 1554 End With Set myItem = myBar.Controls.Add(Type:=msoControlButton) With myItem .Caption = "&Alignment..." .OnAction = "ShowFormatAlignment" .FaceId = 217 End With Set myItem = myBar.Controls.Add(Type:=msoControlButton) With myItem .Caption = "&Font..." .OnAction = "ShowFormatFont" .FaceId = 291 End With
End Sub
</source>
Deletes a control tagged "MyMenu2"
<source lang="vb">
Sub DeleteMyMenu2()
Dim cbc As CommandBarControl Set cbc = Application.rumandBars.FindControl(Tag:="tagName") If Not cbc Is Nothing Then cbc.Delete End If Set cbc = Nothing
End Sub
</source>
<source lang="vb">
Sub DeleteMenu()
On Error Resume Next CommandBars(1).Controls("newCommand").Delete
End Sub
</source>
<source lang="vb">
Sub DeleteMenuItem()
On Error Resume Next CommandBars(1).FindControl(Id:=30007).Controls("&yourControl").Delete
End Sub
</source>
<source lang="vb">
Sub RemoveItemFromShortcut()
On Error Resume Next CommandBars("Cell").Controls("Toggle Word Wrap").Delete
End Sub
</source>
<source lang="vb">
Sub com()
MsgBox CommandBars(1).Controls("Help").ID
End Sub
</source>
<source lang="vb">
Private Sub Workbook_Open()
Application.rumandBars("Cell").Enabled = False
End Sub
</source>
<source lang="vb">
Sub UnhideMenu()
CommandBars(1).Controls("yourControl").Visible = True
End Sub Sub HideMenu()
CommandBars(1).Controls("yourControl").Visible = False
End Sub
</source>
<source lang="vb">
Sub DisableHideMenuItems()
CommandBars("Column").Controls("Hide").Enabled = False CommandBars("Row").Controls("Hide").Enabled = False
End Sub
</source>
<source lang="vb">
Sub DisableCell()
CommandBars("Cell").Enabled = False
End Sub
</source>
<source lang="vb">
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.rumandBars("Cell").Enabled = True
End Sub
</source>
<source lang="vb">
Sub DisableAllShortcutMenus()
Dim cb As CommandBar For Each cb In CommandBars If cb.Type = msoBarTypePopup Then _ cb.Enabled = False Next cb
End Sub
</source>
List Menu Information
<source lang="vb">
Sub ListMenuInfo()
On Error Resume Next For Each Menu In CommandBars(1).Controls For Each MenuItem In Menu.Controls For Each SubMenuItem In MenuItem.Controls Debug.Print Menu.Caption Debug.Print MenuItem.Caption Debug.Print SubMenuItem.Caption Next SubMenuItem Next MenuItem Next Menu
End Sub
</source>
List ShortCut Menus
<source lang="vb">
Sub ListShortCutMenus()
Application.ScreenUpdating = False For Each myCommandBar In CommandBars If myCommandBar.Type = msoBarTypePopup Then Debug.Print myCommandBar.Index Debug.Print myCommandBar.Name For col = 1 To myCommandBar.Controls.Count Debug.Print myCommandBar.Controls(col).Caption Next col End If Next myCommandBar
End Sub
</source>
<source lang="vb">
Sub RemoveHideMenuItems()
CommandBars("Column").Controls("Hide").Delete CommandBars("Row").Controls("Hide").Delete
End Sub
</source>
<source lang="vb">
Sub ResetCellMenu()
CommandBars("Cell").Reset
End Sub
</source>
<source lang="vb">
Sub AddMenuItem()
Dim ViewMenu As CommandBarPopup Dim NewMenuItem As CommandBarButton Set ViewMenu = CommandBars(1).FindControl(ID:=30004) If ViewMenu Is Nothing Then MsgBox "Cannot add menu item." Exit Sub Else Set NewMenuItem = ViewMenu.Controls.Add _ (Type:=msoControlButton) With NewMenuItem .Caption = "&GridLines" .OnAction = "yourActionOrMacro" End With End If
End Sub
</source>