VBA/Excel/Access/Word/Application/Menu — различия между версиями

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

Текущая версия на 12:46, 26 мая 2010

Содержание

Add a new menubar with toggle action

 
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



Adding a menu selection that features a shortcut key

 
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



Adding a menu: Take 1

 
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



Adding and deleting menus automatically

 
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



Adding a new item to the Cell shortcut menu

 
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



Adding a selection to Excel"s Tools menu

 
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



Adding menu items to shortcut menus

 
Sub AddItemToShortcut()
    Set NewItem = CommandBars("Cell").Controls.Add
    With NewItem
       .Caption = "Toggle Word Wrap"
       .OnAction = "ToggleWordWrap"
       .BeginGroup = True
    End With
End Sub



Adding selections and submenu items to the Budgeting menu

 
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



Adding the Budgeting menu to Excel"s main menu bar

 
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



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

 
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



Controling a CommandBarControl"s Visibility

 
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



Create a new menu bar that replaces the existing menu bar

 
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



Create a popup menu

 
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



Create Submenus

 
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



Creating a Menu Bar

 
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



Creating an entirely new and separate shortcut menu

 
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



Deletes a control tagged "MyMenu2"

 
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



Deleting a menu from a menu bar

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



Deleting a menu item from the Tools menu

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



Deleting menu items from shortcut menus

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



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

 
Sub com()
    MsgBox CommandBars(1).Controls("Help").ID
End Sub



Disabling a shortcut menu

 
Private Sub Workbook_Open()
    Application.rumandBars("Cell").Enabled = False
End Sub



Disabling or hiding menus

 
Sub UnhideMenu()
    CommandBars(1).Controls("yourControl").Visible = True
End Sub
Sub HideMenu()
    CommandBars(1).Controls("yourControl").Visible = False
End Sub



Disabling shortcut menu items

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



Disabling shortcut menus

 
Sub DisableCell()
    CommandBars("Cell").Enabled = False
End Sub



Enables the shortcut menu when the workbook is closed.

 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.rumandBars("Cell").Enabled = True
End Sub



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

 
Sub DisableAllShortcutMenus()
    Dim cb As CommandBar
    For Each cb In CommandBars
        If cb.Type = msoBarTypePopup Then _
          cb.Enabled = False
    Next cb
End Sub



List Menu Information

 
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



List ShortCut Menus

 
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



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.

 
Sub RemoveHideMenuItems()
    CommandBars("Column").Controls("Hide").Delete
    CommandBars("Row").Controls("Hide").Delete
End Sub



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

 
Sub ResetCellMenu()
    CommandBars("Cell").Reset
End Sub



Working with checked menu items

 
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
Источник — «http://vbex.ru/index.php?title=VBA/Excel/Access/Word/Application/Menu&oldid=1089»