VBA/Excel/Access/Word/Application/Menu

Материал из VB Эксперт
Перейти к: навигация, поиск

Содержание

Add a new menubar with toggle action

   <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>
   
  


Adding a menu selection that features a shortcut key

   <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>
   
  


Adding a menu: Take 1

   <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>
   
  


Adding and deleting menus automatically

   <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>
   
  


Adding a new item to the Cell shortcut menu

   <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>
   
  


Adding a selection to Excel"s Tools menu

   <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>
   
  


Adding menu items to shortcut menus

   <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>
   
  


Adding selections and submenu items to the Budgeting menu

   <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>
   
  


Adding the Budgeting menu to Excel"s main menu bar

   <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>
   
  


Adds button, combobox, text box and drop down to tools menu

   <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>
   
  


Create a new menu bar that replaces the existing menu bar

   <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>
   
  


Create a popup menu

   <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>
   
  


Create Submenus

   <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>
   
  


Creating an entirely new and separate shortcut menu

   <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>
   
  


Deleting a menu from a menu bar

   <source lang="vb">

Sub DeleteMenu()

   On Error Resume Next
   CommandBars(1).Controls("newCommand").Delete

End Sub

</source>
   
  


Deleting a menu item from the Tools menu

   <source lang="vb">

Sub DeleteMenuItem()

   On Error Resume Next
   CommandBars(1).FindControl(Id:=30007).Controls("&yourControl").Delete

End Sub

</source>
   
  


Deleting menu items from shortcut menus

   <source lang="vb">

Sub RemoveItemFromShortcut()

   On Error Resume Next
   CommandBars("Cell").Controls("Toggle Word Wrap").Delete

End Sub

</source>
   
  


Determined the Id property of the Help menu by executing the following statement:

   <source lang="vb">

Sub com()

   MsgBox CommandBars(1).Controls("Help").ID

End Sub

</source>
   
  


Disabling a shortcut menu

   <source lang="vb">

Private Sub Workbook_Open()

   Application.rumandBars("Cell").Enabled = False

End Sub

</source>
   
  


Disabling or hiding menus

   <source lang="vb">

Sub UnhideMenu()

   CommandBars(1).Controls("yourControl").Visible = True

End Sub Sub HideMenu()

   CommandBars(1).Controls("yourControl").Visible = False

End Sub

</source>
   
  


Disabling shortcut menu items

   <source lang="vb">

Sub DisableHideMenuItems()

   CommandBars("Column").Controls("Hide").Enabled = False
   CommandBars("Row").Controls("Hide").Enabled = False

End Sub

</source>
   
  


Disabling shortcut menus

   <source lang="vb">

Sub DisableCell()

   CommandBars("Cell").Enabled = False

End Sub

</source>
   
  


Enables the shortcut menu when the workbook is closed.

   <source lang="vb">

Private Sub Workbook_BeforeClose(Cancel As Boolean)

   Application.rumandBars("Cell").Enabled = True

End Sub

</source>
   
  


If you want to disable all shortcut menus, use the following procedure:

   <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>
   
  


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.

   <source lang="vb">

Sub RemoveHideMenuItems()

   CommandBars("Column").Controls("Hide").Delete
   CommandBars("Row").Controls("Hide").Delete

End Sub

</source>
   
  


Resetting shortcut menus: The Reset method restores a shortcut menu to its original condition.

   <source lang="vb">

Sub ResetCellMenu()

   CommandBars("Cell").Reset

End Sub

</source>
   
  


Working with checked menu items

   <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>