VBA/Excel/Access/Word/Application/CommandBar

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

Содержание

Add a new commandbar

   <source lang="vb">

Sub AddNewCB() 

  Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
  On Error GoTo AddNewCB_Err
  Set myCommandBar = CommandBars.Add(Name:="Sample Toolbar", Position:= msoBarFloating)
  myCommandBar.Visible = True
  Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
  With myCommandBarCtl
     .Caption = "Button"
     .Style = msoButtonCaption
     .TooltipText = "Display Message Box"
     .OnAction = "=MsgBox(""You pressed a toolbar button!"")"
  End With
  Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
  With myCommandBarCtl
     .FaceId = 1000
     .Caption = "Toggle Button"
     .TooltipText = "Toggle First Button"
     .OnAction = "=ToggleButton()"
  End With
  Set myCommandBarCtl = myCommandBar.Controls.Add(msoControlComboBox)
  With myCommandBarCtl
     .Caption = "Drop Down"
     .Width = 100
     .AddItem "Create Button", 1
     .AddItem "Remove Button", 2
     .DropDownWidth = 100
     .OnAction = "=AddRemoveButton()"
  End With
  Exit Sub

AddNewCB_Err: 

  Debug.Print Err.number & vbCr & Err.Description
  Exit Sub

End Sub Function ToggleButton() 

  Dim CBButton As CommandBarControl
  On Error GoTo ToggleButton_Err
  Set CBButton = CommandBars("Sample Toolbar").Controls(1)
  CBButton.Visible = Not CBButton.Visible
  Exit Function

ToggleButton_Err: 

  Debug.Print Err.number & vbCr & Err.Description
  Exit Function

End Function Function AddRemoveButton() 

  Dim myCommandBar As CommandBar, CBCombo As CommandBarComboBox
  Dim CBNewButton As CommandBarButton
  
  On Error GoTo AddRemoveButton_Err
  
  Set myCommandBar = CommandBars("Sample Toolbar")
  Set CBCombo = myCommandBar.Controls(3)
  
  Select Case CBCombo.ListIndex
     Case 1
        Set CBNewButton = myCommandBar.Controls.Add(Type:=msoControlButton)
        With CBNewButton
           .Caption = "New Button"
           .Style = msoButtonCaption
           .BeginGroup = True
           .Tag = "New Button"
           .OnAction = "=MsgBox(""This is a new button!"")"
        End With
     Case 2
        Set CBNewButton = myCommandBar.FindControl(Tag:="New Button")
        CBNewButton.Delete
  End Select
  Exit Function

AddRemoveButton_Err: 

  If Err.number = 91 Then
     Debug.Print "Cannot remove button that does not exist!"
     Exit Function
  Else
     Debug.Print Err.number & vbCr & Err.Description
     Exit Function
  End If

End Function 

</source>


Add ControlButton to CommandBar

   <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 = "=MsgBox(""You clicked Enable ClickMe"")"
     .Parameter = 1
     .BeginGroup = True
  End With
  Set myCommandBarSubCtl = myCommandBarCtl.Controls.Add(Type:=msoControlButton)
  With myCommandBarSubCtl
     .Style = msoButtonIconAndCaption
     .Caption = "Di&sable ClickMe"
     .FaceId = 276
     .OnAction = "=MsgBox(""You Disable ClickMe"")"
     .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 = "=MsgBox(""You set visibility off"")"
  End With
  Exit Sub

AddNewMB_Err: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Sub

End Sub 

</source>


Adding a control to a command bar

   <source lang="vb">

Sub AddButton() 

   Set NewBtn = CommandBars("MyToolbar").Controls.Add _
     (Type:=msoControlButton)
   With NewBtn
      .FaceId = 300
      .OnAction = "MyMacro"
      .Caption = "Tooltip goes here"
   End With

End Sub 

</source>


Add PopupControl to CommandBar

   <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

AddNewMB_Err: 

  msgBox "Error " & 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: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Function

End Function 

</source>


Adjusting a control"s Visible property

   <source lang="vb">

Sub ToggleAllToolbars() 

   For Each cb In CommandBars
       If cb.Type = msoBarTypeNormal Then
           cb.Visible = Not cb.Visible
       End If
   Next cb

End Sub 

</source>


Attaching a drop-down list to a command bar

   <source lang="vb">

Sub Make() 

   Dim TBar As commandBar
   Dim NewDD As CommandBarControl
   Set TBar = CommandBars.Add
   Set NewDD = CommandBars("myBar").Controls.Add(Type:=msoControlDropdown)
   With NewDD
       .Caption = "Date"
       .OnAction = "yourAction"
       .Style = msoButtonAutomatic
       For i = 1 To 2
           .AddItem "Click"
       Next i
       .ListIndex = 1
   End With

End Sub Sub yourAction() 

   With CommandBars("MonthList").Controls("DateDD")
       ActiveCell.value = .List(.ListIndex)
   End With

End Sub 

</source>


Changing a control"s caption dynamically: Showing the user the current cell"s number format

   <source lang="vb">

Sub MakeNumberFormatDisplay() 

   Dim TBar As CommandBar
   Dim NewBtn As CommandBarButton
   Set TBar = CommandBars.Add
   With TBar
       .Name = "Number Format"
       .Visible = True
   End With
   
   Set NewBtn = CommandBars("Number Format").Controls.Add(Type:=msoControlButton)
   With NewBtn
       .Caption = ""
       .OnAction = "ChangeNumFormat"
       .Style = msoButtonCaption
   End With

End Sub 

</source>


CommandBar Object

   <source lang="vb">

Sub CommandBarCount() 

  MsgBox "There are " & CommandBars.count & " command bars"

End Sub 

</source>


CommandBars collection

   <source lang="vb">

Sub com() 

   MsgBox CommandBars(1).Name

End Sub 

</source>


Counting custom toolbars

   <source lang="vb">

Sub CustomToolbars() 

   Dim cb As CommandBar
   For Each cb In CommandBars
       If cb.Type = msoBarTypeNormal Then
           If Not cb.BuiltIn Then
               Debug.Print "Not"
           End If
       End If
   Next cb

End Sub 

</source>


Create Shortcut

   <source lang="vb">

Sub CreateShortcut() 

   DeleteShortcut
   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 Sub ShowFormatNumber() 

   Application.Dialogs(xlDialogFormatNumber).Show

End Sub Sub ShowFormatAlignment() 

   Application.Dialogs(xlDialogAlignment).Show

End Sub Sub ShowFormatFont() 

   Application.Dialogs(xlDialogFormatFont).Show

End Sub 

</source>


Creating a command bar: Set some properties when you create a new toolbar

   <source lang="vb">

Sub CreateAToolbar() 

   Dim TBar As CommandBar
   Set TBar = CommandBars.Add
   With TBar
       .name = "MyToolbar"
       .Top = 0
       .Left = 0
       .Visible = True
   End With

End Sub 

</source>


Creating a Toolbar: AddRemoveButton

   <source lang="vb">

Sub AddNewCB() 

  Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
  On Error GoTo AddNewCB_Err
 Set myCommandBar = CommandBars.Add(Name:="Sample Toolbar", Position:= _
     msoBarFloating)
  myCommandBar.Visible = True
 Set myCommandBarCtl = myCommandBar.Controls.Add(msoControlComboBox)
  With myCommandBarCtl
     .Caption = "Drop Down"
     .Width = 100
     .AddItem "Create Button", 1
     .AddItem "Remove Button", 2
     .DropDownWidth = 100
     .OnAction = "=AddRemoveButton()"
  End With
  Exit Sub

AddNewCB_Err: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Sub

End Sub Function AddRemoveButton() 

  Dim myCommandBar As CommandBar, CBCombo As CommandBarComboBox
  Dim CBNewButton As CommandBarButton
  On Error GoTo AddRemoveButton_Err
  Set myCommandBar = CommandBars("Sample Toolbar")
  Set CBCombo = myCommandBar.Controls(3)
  Select Case CBCombo.ListIndex
     Case 1
        Set CBNewButton = myCommandBar.Controls.Add(Type:=msoControlButton)
        With CBNewButton
           .Caption = "New Button"
           .Style = msoButtonCaption
           .BeginGroup = True
           .Tag = "New Button"
           .OnAction = "=MsgBox(""This is a new button!"")"
        End With
     Case 2
        Set CBNewButton = myCommandBar.FindControl(Tag:="New Button")
        CBNewButton.Delete
  End Select
  Exit Function

AddRemoveButton_Err: 

  If Err.number = 91 Then
     msgBox "Cannot remove button that does not exist!"
     Exit Function
  Else
    msgBox "Error " & Err.number & vbCr & Err.Description
    Exit Function
  End If

End Function 

</source>


Creating a Toolbar and assign its action

   <source lang="vb">

Function ToggleButton() 

  Dim CBButton As CommandBarControl
  On Error GoTo ToggleButton_Err
  Set CBButton = CommandBars("Sample Toolbar").Controls(1)
  CBButton.Visible = Not CBButton.Visible
  Exit Function

ToggleButton_Err: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Function

End Function Sub AddNewCB() 

  Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
  On Error GoTo AddNewCB_Err
 Set myCommandBar = CommandBars.Add(Name:="Sample Toolbar", Position:= _
     msoBarFloating)
  myCommandBar.Visible = True
  Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
  With myCommandBarCtl
     .FaceId = 1000
     .Caption = "Toggle Button"
     .TooltipText = "Toggle First Button"
     .OnAction = "=ToggleButton()"
  End With
  Exit Sub

AddNewCB_Err: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Sub

End Sub 

</source>


Creating a Toolbar and display MsgBox in its action

   <source lang="vb">

Sub AddNewCB() 

  Dim myCommandBar As CommandBar, myCommandBarCtl As CommandBarControl
  On Error GoTo AddNewCB_Err
 Set myCommandBar = CommandBars.Add(Name:="Sample Toolbar", Position:= _
     msoBarFloating)
  myCommandBar.Visible = True
 Set myCommandBarCtl = myCommandBar.Controls.Add(Type:=msoControlButton)
  With myCommandBarCtl
     .Caption = "Button"
     .Style = msoButtonCaption
     .TooltipText = "Display Message Box"
     .OnAction = "=MsgBox(""You pressed a toolbar button!"")"
  End With
  
  Exit Sub

AddNewCB_Err: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Sub

End Sub 

</source>


Custom Toolbars

   <source lang="vb">

Private tlbMyToolbar As CommandBar "Add tool bar Sub AddToolbar() 

   Dim tlbMyButton As CommandBarButton
   Set tlbMyToolbar = Application.rumandBars.Add( _
       name:=" Example Toolbar", _
       Position:=msoBarFloating, _
       Temporary:=True)
   tlbMyToolbar.Visible = True
   Set tlbMyButton = tlbMyToolbar.Controls.Add( _
       Type:=msoControlButton, _
       Temporary:=True)
   tlbMyButton.Style = msoButtonIconAndCaption
   tlbMyButton.Picture = LoadPicture(ActiveWorkbook.Path & "\myImage.bmp")
   tlbMyButton.Caption = "Test"

End Sub 

</source>


deletes a control that has a caption of SortButton.

   <source lang="vb">

Sub commandBar() 

   CommandBars("MyToolbar").Controls("SortButton").Delete

End Sub 

</source>


Determines if a given command bar name exists

   <source lang="vb">

Sub TestCommandBarUtilities() 

   Debug.Print CommandBarExists("Worksheet Menu Bar") 
   Debug.Print CommandBarExists("Formatting") 
   Debug.Print CommandBarExists("Not a command bar")

End Sub Function CommandBarExists(sName As String) As Boolean 

   Dim s As String 
   On Error GoTo bWorksheetExistsErr 
   s = Application.rumandBars(sName).Name 
   CommandBarExists = True 
   Exit Function

bWorksheetExistsErr: 

   CommandBarExists = False

End Function 

</source>


Display Control Detail

   <source lang="vb">

Private Sub DisplayControlDetail() 

   Dim cb As CommandBar 
   Dim cbc As CommandBarControl 
   On Error Resume Next 
   For Each cb In Application.rumandBars 
       For Each cbc In cb.Controls 
           Debug.Print Replace(cbc.Caption, "&", "") 
           Debug.Print cbc.Caption 
           Debug.Print cbc.Index 
           Debug.Print cbc.BuiltIn 
           Debug.Print cbc.Enabled 
           Debug.Print cbc.Visible 
           Debug.Print cbc.IsPriorityDropped 
           Debug.Print cbc.Priority 
           Debug.Print TranslateControlType(cbc.Type) 
           Debug.Print cbc.Controls.Count 
       Next 
   Next
   Set cbc = Nothing

End Sub Function TranslateControlType(vType As MsoControlType) As String 

   Dim sType As String 
   Select Case vType 
       Case Is = MsoControlType.msoControlActiveX 
           sType = "ActiveX" 
       Case Is = MsoControlType.msoControlAutoCompleteCombo 
           sType = "Auto Complete Combo" 
       Case Is = MsoControlType.msoControlButton 
           sType = "Button" 
       Case Is = MsoControlType.msoControlButtonDropdown 
           sType = "Button Dropdown" 
       Case Is = MsoControlType.msoControlButtonPopup 
           sType = "Button Popup" 
       Case Is = MsoControlType.msoControlComboBox 
           sType = "Combo Box" 
       Case Is = MsoControlType.msoControlCustom 
           sType = "Custom" 
       Case Is = MsoControlType.msoControlDropdown 
           sType = "Dropdown" 
       Case Is = MsoControlType.msoControlEdit 
           sType = "Edit" 
       Case Is = MsoControlType.msoControlExpandingGrid 
           sType = "Expanding Grid" 
       Case Is = MsoControlType.msoControlGauge 
           sType = "Gauge" 
       Case Is = MsoControlType.msoControlGenericDropdown 
           sType = "Generic Dropdown" 
       Case Is = MsoControlType.msoControlGraphicCombo 
           sType = "Graphic Combo" 
       Case Is = MsoControlType.msoControlGraphicDropdown 
           sType = "Graphic Dropdown" 
       Case Is = MsoControlType.msoControlGraphicPopup 
           sType = "Graphic Popup" 
       Case Is = MsoControlType.msoControlGrid 
           sType = "Grid" 
       Case Is = MsoControlType.msoControlLabel 
           sType = "Label" 
       Case Is = MsoControlType.msoControlLabelEx 
           sType = "Label Ex" 
       Case Is = MsoControlType.msoControlOCXDropdown 
           sType = "OCX Dropdown" 
       Case Is = MsoControlType.msoControlPane 
           sType = "Pane" 
       Case Is = MsoControlType.msoControlPopup 
           sType = "Popup" 
       Case Is = MsoControlType.msoControlSpinner 
           sType = "Spinner" 
       Case Is = MsoControlType.msoControlSplitButtonMRUPopup 
           sType = "Split Button MRU Popup" 
       Case Is = MsoControlType.msoControlSplitButtonPopup 
           sType = "Split Button Popup" 
       Case Is = MsoControlType.msoControlSplitDropdown 
           sType = "Split Dropdown" 
       Case Is = MsoControlType.msoControlSplitExpandingGrid 
           sType = "Split Expanding Grid" 
       Case Is = MsoControlType.msoControlWorkPane 
           sType = "Work Pane" 
       Case Else 
           sType = "Unknown control type" 
   End Select 
   TranslateControlType = sType

End Function 

</source>


display shortcut menu with the ShowPopup method

   <source lang="vb">

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean) 

   CommandBars("MyShortcut").ShowPopup
   Cancel = True

End Sub 

</source>


displays the Caption property for the first Control object contained in the Standard toolbar, whose index is 3.

   <source lang="vb">

Sub Test() 

   MsgBox CommandBars(3).Controls(1).Caption

End Sub 

</source>


Finding Visible Controls with FindControls

   <source lang="vb">

Sub FindVisibleControls() 

   Dim ctrls As CommandBarControls
   Dim ctrl As CommandBarControl
   Set ctrls = Application.rumandBars.FindControls(, , , True)
   For Each ctrl In ctrls
       Debug.Print ctrl.Parent.name
       Debug.Print ctrl.Caption
       Debug.Print ctrl.Index
       Debug.Print ctrl.ID
       Debug.Print ctrl.Enabled
       Debug.Print ctrl.Visible
       Debug.Print ctrl.IsPriorityDropped
       Debug.Print TranslateControlType(ctrl.Type)
   Next
   Set ctrl = Nothing
   Set ctrls = Nothing

End Sub Function TranslateControlType(vType As MsoControlType) As String 

   Dim sType As String
   Select Case vType
       Case Is = MsoControlType.msoControlActiveX
           sType = "ActiveX"
       Case Is = MsoControlType.msoControlAutoCompleteCombo
           sType = "Auto Complete Combo"
       Case Is = MsoControlType.msoControlButton
           sType = "Button"
       Case Is = MsoControlType.msoControlButtonDropdown
           sType = "Button Dropdown"
       Case Is = MsoControlType.msoControlButtonPopup
           sType = "Button Popup"
       Case Is = MsoControlType.msoControlComboBox
           sType = "Combo Box"
       Case Is = MsoControlType.msoControlCustom
           sType = "Custom"
       Case Is = MsoControlType.msoControlDropdown
           sType = "Dropdown"
       Case Is = MsoControlType.msoControlEdit
           sType = "Edit"
       Case Is = MsoControlType.msoControlExpandingGrid
           sType = "Expanding Grid"
       Case Is = MsoControlType.msoControlGauge
           sType = "Gauge"
       Case Is = MsoControlType.msoControlGenericDropdown
           sType = "Generic Dropdown"
       Case Is = MsoControlType.msoControlGraphicCombo
           sType = "Graphic Combo"
       Case Is = MsoControlType.msoControlGraphicDropdown
           sType = "Graphic Dropdown"
       Case Is = MsoControlType.msoControlGraphicPopup
           sType = "Graphic Popup"
       Case Is = MsoControlType.msoControlGrid
           sType = "Grid"
       Case Is = MsoControlType.msoControlLabel
           sType = "Label"
       Case Is = MsoControlType.msoControlLabelEx
           sType = "Label Ex"
       Case Is = MsoControlType.msoControlOCXDropdown
           sType = "OCX Dropdown"
       Case Is = MsoControlType.msoControlPane
           sType = "Pane"
       Case Is = MsoControlType.msoControlPopup
           sType = "Popup"
       Case Is = MsoControlType.msoControlSpinner
           sType = "Spinner"
       Case Is = MsoControlType.msoControlSplitButtonMRUPopup
           sType = "Split Button MRU Popup"
       Case Is = MsoControlType.msoControlSplitButtonPopup
           sType = "Split Button Popup"
       Case Is = MsoControlType.msoControlSplitDropdown
           sType = "Split Dropdown"
       Case Is = MsoControlType.msoControlSplitExpandingGrid
           sType = "Split Expanding Grid"
       Case Is = MsoControlType.msoControlWorkPane
           sType = "Work Pane"
       Case Else
           sType = "Unknown control type"
   End Select
   TranslateControlType = sType

End Function 

</source>


Get the type of CommandBars

   <source lang="vb">

Sub listCommandBars() 

  Dim comBar As CommandBar
  Dim comBarType As String
  
  For Each comBar In CommandBars
     Select Case comBar.Type
     
     Case msoBarTypeNormal
       comBarType = "Toolbar"
     Case msoBarTypeMenuBar
       comBarType = "Menu Bar"
     Case msoBarTypePopup
       comBarType = "Shortcut"
     End Select
     
     Debug.Print comBar.Index, comBar.Name, comBarType, comBar.Visible
   Next

End Sub 

</source>


how your VBA code can change the position of a toolbar.

   <source lang="vb">

Sub MoveToolbar() 

   With CommandBars("MyToolbar")
       OldLeft = .Left
       OldTop = .Top
       For i = 1 To 60
           .Left = Int(vidWidth * Rnd)
           .Top = Int(vidHeight * Rnd)
           DoEvents
       Next i
       .Left = OldLeft
       .Top = OldTop
   End With

End Sub 

</source>


Inspecting a CommandBar

   <source lang="vb">

Sub DisplayGeneralInfo() 

   Dim cb As CommandBar 
   For Each cb In Application.rumandBars 
     Debug.Print "Name:" & cb.Name 
     Debug.Print "Index:" & cb.Index 
     Debug.Print "Built In:" & cb.BuiltIn 
     Debug.Print "Enabled:"  cb.Enabled 
     Debug.Print "Visible:" & cb.Visible 
     Debug.Print "Type:" & TranslateCommandBarType(cb.Type) 
     Debug.Print "Position:" & TranslateCommandBarPosition(cb.Position) 
     Debug.Print "Control Count:" & cb.Controls.Count 
   Next

End Sub Function TranslateCommandBarPosition(vType As MsoBarPosition) As String 

   Dim sPosition As String 
   Select Case vType 
       Case Is = MsoBarPosition.msoBarBottom 
           sPosition = "Bottom" 
       Case Is = MsoBarPosition.msoBarFloating 
           sPosition = "Floating" 
       Case Is = MsoBarPosition.msoBarLeft 
           sPosition = "Left" 
       Case Is = MsoBarPosition.msoBarMenuBar 
               sPosition = "Menu Bar" 
       Case Is = MsoBarPosition.msoBarPopup 
           sPosition = "Popup" 
       Case Is = MsoBarPosition.msoBarRight 
           sPosition = "Right" 
       Case Is = MsoBarPosition.msoBarTop 
           sPosition = "Top" 
       Case Else 
           sPosition = "Unknown position" 
   End Select 
   TranslateCommandBarPosition = sPosition

End Function Function TranslateCommandBarType(vType As MsoBarType) As String 

   Dim sType As String 
   Select Case vType 
       Case Is = MsoBarType.msoBarTypeMenuBar 
           sType = "Menu Bar" 
       Case Is = MsoBarType.msoBarTypeNormal 
           sType = "Normal" 
       Case Is = MsoBarType.msoBarTypePopup 
           sType = "Popup" 
       Case Else 
           sType = "Unknown type" 
   End Select 
   TranslateCommandBarType = sType

End Function 

</source>


Listing all controls on all toolbars

   <source lang="vb">

Sub ShowAllToolbarControls() 

   For Each myCommandBar In CommandBars
       If myCommandBar.Type = msoBarTypeNormal Then
           Debug.Print myCommandBar.name
           For Each ctl In myCommandBar.Controls
               Debug.Print ctl.Caption
           Next ctl
       End If
   Next myCommandBar

End Sub 

</source>


Listing the controls on a command bar

   <source lang="vb">

Sub ShowControlCaptions() 

   Dim myCommandBar As commandBar
   Set myCommandBar = CommandBars("Standard")
   For Each ctl In myCommandBar.Controls
       Debug.Print ctl.Caption
   Next ctl
</source>


Properties of CommandBar controls

   <source lang="vb">

Sub ShowShortcutMenuItems() 

 Dim myCommandBar As CommandBar
 Dim Ctl As CommandBarControl
 Application.ScreenUpdating = False
 For Each myCommandBar In Application.rumandBars
   If myCommandBar.Type = msoBarTypePopup Then
     Debug.Print  myCommandBar.Index
     Debug.Print  myCommandBar.Name
     For Each Ctl In myCommandBar.Controls
       If Ctl.Visible Then
         Debug.Print  Ctl.Caption
       Else
         Debug.Print  "<" & Ctl.Caption & ">"
       End If
    Next Ctl
  End If
 Next myCommandBar

End Sub 

</source>


Rather than use an index number to refer to a control, you can use its Caption property setting

   <source lang="vb">

Sub Test2() 

   MsgBox CommandBars("Standard").Controls("New").Caption

End Sub 

</source>


Referring to command bars

   <source lang="vb">

Function CommandBarExists(n) As Boolean 

   Dim cb As CommandBar
   For Each cb In CommandBars
       If UCase(cb.Name) = UCase(n) Then
           CommandBarExists = True
           Exit Function
       End If
   Next cb
   CommandBarExists = False

End Function 

</source>


Removes a toolbar specified by the name passed in

   <source lang="vb">

Sub RemoveToolbar(tlbarName As String) 

   Dim myCommandBar As CommandBar
   For Each myCommandBar In Application.rumandBars
       If myCommandBar.Name = tlbarName Then
           myCommandBar.Delete
           Exit For
       End If
   Next

End Sub 

</source>


Removing all toolbars and then restoring them

   <source lang="vb">

Sub HideAllToolbars() 

   Dim toolBar As commandBar
   Dim toolBarNum As Integer
   Dim toolBarSheet As Worksheet
   Set toolBarSheet = Sheets("Sheet1")
   Application.ScreenUpdating = False
   toolBarSheet.Cells.Clear
   
   toolBarNum = 0
   For Each toolBar In CommandBars
       If toolBar.Type = msoBarTypeNormal Then
           If toolBar.Visible Then
               toolBarNum = toolBarNum + 1
               toolBar.Visible = False
               toolBarSheet.Cells(toolBarNum, 1) = toolBar.name
           End If
       End If
   Next toolBar
   Application.ScreenUpdating = True

End Sub 

</source>


Replacing Excel"s built-in menu with your own

   <source lang="vb">

Sub MakeMenuBar() 

   Dim NewMenuBar As commandBar
   Set NewMenuBar = CommandBars.Add(MenuBar:=True)
   With NewMenuBar
       .name = "MyMenuBar"
       .Visible = True
   End With
   
   CommandBars("Worksheet Menu Bar") _
    .Controls(1).Copy Bar:=CommandBars("MyMenuBar")
   Set NewMenu = NewMenuBar.Controls.Add _
     (Type:=msoControlPopup)
   NewMenu.Caption = "&Commands"
   Set NewItem = NewMenu.Controls.Add(Type:=msoControlButton)
   With NewItem
       .Caption = "&Restore Normal Menu"
       .OnAction = "DeleteMenuBar"
   End With
   Set NewItem = NewMenu.Controls.Add(Type:=msoControlButton)
   With NewItem
       .Caption = "&Help"
       .OnAction = "DeleteMenuBar"
   End With

End Sub Sub DeleteMenuBar() 

   On Error Resume Next
   CommandBars("MyMenuBar").Delete
   On Error GoTo 0

End Sub 

</source>


Reset CommandBar

   <source lang="vb">

Sub ResetAll() 

   Dim myCommandBar As CommandBar
   For Each myCommandBar In Application.rumandBars
       If myCommandBar.Type = msoBarTypePopup Then
           myCommandBar.Reset
           myCommandBar.Enabled = True
       End If
   Next myCommandBar

End Sub 

</source>


Restores the Worksheet Menu Bar to its native state

   <source lang="vb">

Private Sub ResetCommandBar() 

   Application.rumandBars("Worksheet Menu Bar").Reset

End Sub 

</source>


Restore tool bar

   <source lang="vb">

Sub RestoreToolbars() 

   Dim toolBarSheet As Worksheet
   Set toolBarSheet = Sheets("toolBarSheet")
   Application.ScreenUpdating = False
   On Error Resume Next
   For Each Cell In toolBarSheet.range("A:A") _
     .SpecialCells(xlCellTypeConstants)
       CommandBars(Cell.value).Visible = True
   Next Cell
   Application.ScreenUpdating = True

End Sub 

</source>


Save list of all predefined commands and their ID numbers in a file

   <source lang="vb">

Sub IdList() 

 On Error Resume Next
 If Application.Version >= 10# Then Exit Sub
 Dim c As CommandBar, i
 Set c = CommandBars.Add
 Open ThisWorkbook.Path + "\CommandBar.txt" For Output As #1
 For i = 0 To 32
   c.Controls.Add Id:=i
   If c.Controls(1).Caption <> "" And _
      c.Controls(1).Caption <> "[Command not available]" And _
      c.Controls(1).Caption <> "custom" Then
     Print #1, i, c.Controls(1).Caption
   End If
   c.Controls(1).Delete
 Next i
 c.Delete
 Close #1

End Sub 

</source>


Set Control style, Action, group, faceid and caption

   <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 = "S&ample Menu Disable"
     .FaceId = 59
     .OnAction = "=SampleMenuDisable()"
     .Parameter = 1
     .BeginGroup = True
  End With

AddNewMB_Err: 

  msgBox "Error " & Err.number & vbCr & Err.Description
  Exit Sub

End Sub Function SampleMenuDisable() 

  Application.rumandBars("Sample Menu Bar").Visible = False
  Application.rumandBars("Menu Bar").Visible = True

End Function 

</source>


sets the FaceId property of the first button on the MyToolbar toolbar image to 45, which is the code number for a mailbox icon.

   <source lang="vb">

Sub faceID() 

   CommandBars("MyToolbar").Controls(1).FaceId = 45

End Sub 

</source>


Show All Toolbar Controls

   <source lang="vb">

Sub ShowAllToolbarControls() 

   Cells.Clear
   Row = 1
   For Each myCommandBar In CommandBars
       If myCommandBar.Type = msoBarTypeNormal Then
           Cells(Row, 1) = myCommandBar.Name
           For Each ctl In myCommandBar.Controls
               Cells(Row, 2) = ctl.Caption
               Row = Row + 1
           Next ctl
       End If
   Next myCommandBar

End Sub 

</source>


Show CommandBar Names

   <source lang="vb">

Sub ShowCommandBarNames() 

   Cells.Clear
   Row = 1
   For Each myCommandBar In CommandBars
       Cells(Row, 1) = myCommandBar.Index
       Cells(Row, 2) = myCommandBar.Name
       Select Case myCommandBar.Type
           Case msoBarTypeNormal
               Cells(Row, 3) = "Toolbar"
           Case msoBarTypeMenuBar
               Cells(Row, 3) = "Menu Bar"
           Case msoBarTypePopUp
               Cells(Row, 3) = "Shortcut"
       End Select
       Row = Row + 1
   Next myCommandBar

End Sub 

</source>


show/hide check symbol

   <source lang="vb">

Sub MenuCommand2_OnAction() 

 With CommandBars.ActionControl
   If .State = msoButtonDown Then
     .State = msoButtonUp
   Else
     .State = msoButtonDown
   End If
 End With

End Sub 

</source>


Shows or hides a command bar.

   <source lang="vb">

Sub TestCommandBarUtilities() 

   ShowCommandBar "Borders", True

End Sub Sub ShowCommandBar(sName As String, bShow As Boolean) 

   If CommandBarExists(sName) Then 
       Application.rumandBars(sName).Visible = bShow 
   End If

End Sub 

</source>


simply copies the NumberFormat property of the ActiveCell to the Caption property of the button control.

   <source lang="vb">

Sub UpdateToolbar() 

   On Error Resume Next
   CommandBars("Number Format").Controls(1).Caption = ActiveCell.NumberFormat
   If Err <> 0 Then CommandBars("Number Format").Controls(1).Caption = ""

End Sub 

</source>


The custom toolbar is removed with this procedure

   <source lang="vb">

Sub RemoveToolBar() 

   On Error Resume Next
   Application.rumandBars("ExcelVBADummies").Delete

End Sub Sub Main() 

 Debug.Print FirstName()

End Sub 

 Function FirstName()
      Dim FullName As String
      Dim FirstSpace As Integer
      FullName = Application.userName
      FirstSpace = InStr(FullName, " ")
      If FirstSpace = 0 Then
          FirstName = FullName
      Else
          FirstName = Left(FullName, FirstSpace - 1)
      End If
 End Function
</source>


The Protection constants are additive: apply different types of protection with a single command

   <source lang="vb">

Sub commandBar() 

   Set cb = CommandBars("MyToolbar")
   cb.Protection = msoBarNoCustomize + msoBarNoMove

End Sub 

</source>


The Protection property of a CommandBar object provides you with many options for protecting a CommandBar.

   <source lang="vb">

Sub commdBar() 

   CommandBars("MyToolbar").Protection = msoBarNoCustomize

End Sub 

</source>


This toolbar exists only when the cell pointer falls within a given range

   <source lang="vb">

Sub CreateToolbar() 

   Dim myBar As commandBar
   Dim Button As CommandBarButton
   
   Set myBar = CommandBars.Add
   For i = 1 To 4
       Set Button = myBar.Controls.Add(msoControlButton)
       With Button
           .OnAction = "Button" & i
           .FaceId = i + 37
       End With
   Next i
   myBar.name = "myBar"

End Sub 

</source>


To delete a control from a CommandBar object, use the Delete method of the Controls collection

   <source lang="vb">

Sub delBar() 

   CommandBars("MyToolbar").Controls(1).Delete

End Sub 

</source>


Translates a MsoBarPosition enumeration into a text description of the bar position.

   <source lang="vb">

Sub Inventory() 

   Dim cb As commandBar
   For Each cb In Application.rumandBars
       Debug.Print TranslateCommandBarPosition(cb.Position)
   Next
   Set cb = Nothing

End Sub Function TranslateCommandBarPosition(vType As MsoBarPosition) As String 

   Dim sPosition As String
   Select Case vType
       Case Is = MsoBarPosition.msoBarBottom
           sPosition = "Bottom"
       Case Is = MsoBarPosition.msoBarFloating
           sPosition = "Floating"
       Case Is = MsoBarPosition.msoBarLeft
           sPosition = "Left"
       Case Is = MsoBarPosition.msoBarMenuBar
               sPosition = "Menu Bar"
       Case Is = MsoBarPosition.msoBarPopup
           sPosition = "Popup"
       Case Is = MsoBarPosition.msoBarRight
           sPosition = "Right"
       Case Is = MsoBarPosition.msoBarTop
           sPosition = "Top"
       Case Else
           sPosition = "Unknown position"
   End Select
   TranslateCommandBarPosition = sPosition

End Function 

</source>


Translates a MsoBarType enumeration into a text description of the bar type.

   <source lang="vb">

Sub Inventory() 

   Dim cb As commandBar
   For Each cb In Application.rumandBars
       Debug.Print TranslateCommandBarType(cb.Type)
   Next
   Set cb = Nothing

End Sub Function TranslateCommandBarType(vType As MsoBarType) As String 

   Dim sType As String
   Select Case vType
       Case Is = MsoBarType.msoBarTypeMenuBar
           sType = "Menu Bar"
       Case Is = MsoBarType.msoBarTypeNormal
           sType = "Normal"
       Case Is = MsoBarType.msoBarTypePopup
           sType = "Popup"
       Case Else
           sType = "Unknown type"
   End Select
   TranslateCommandBarType = sType

End Function 

</source>


Translates a MsoControlType enumeration into a text description of the control type.

   <source lang="vb">

Private Sub DisplayControlDetail() 

   Dim cb As CommandBar 
   Dim cbc As CommandBarControl 
   On Error Resume Next 
   For Each cb In Application.rumandBars 
       For Each cbc In cb.Controls 
           Debug.Print cbc.Caption 
           Debug.Print TranslateControlType(cbc.Type) 
       Next 
   Next
   Set cbc = Nothing

End Sub Function TranslateControlType(vType As MsoControlType) As String 

   Dim sType As String 
   Select Case vType 
       Case Is = MsoControlType.msoControlActiveX 
           sType = "ActiveX" 
       Case Is = MsoControlType.msoControlAutoCompleteCombo 
           sType = "Auto Complete Combo" 
       Case Is = MsoControlType.msoControlButton 
           sType = "Button" 
       Case Is = MsoControlType.msoControlButtonDropdown 
           sType = "Button Dropdown" 
       Case Is = MsoControlType.msoControlButtonPopup 
           sType = "Button Popup" 
       Case Is = MsoControlType.msoControlComboBox 
           sType = "Combo Box" 
       Case Is = MsoControlType.msoControlCustom 
           sType = "Custom" 
       Case Is = MsoControlType.msoControlDropdown 
           sType = "Dropdown" 
       Case Is = MsoControlType.msoControlEdit 
           sType = "Edit" 
       Case Is = MsoControlType.msoControlExpandingGrid 
           sType = "Expanding Grid" 
       Case Is = MsoControlType.msoControlGauge 
           sType = "Gauge" 
       Case Is = MsoControlType.msoControlGenericDropdown 
           sType = "Generic Dropdown" 
       Case Is = MsoControlType.msoControlGraphicCombo 
           sType = "Graphic Combo" 
       Case Is = MsoControlType.msoControlGraphicDropdown 
           sType = "Graphic Dropdown" 
       Case Is = MsoControlType.msoControlGraphicPopup 
           sType = "Graphic Popup" 
       Case Is = MsoControlType.msoControlGrid 
           sType = "Grid" 
       Case Is = MsoControlType.msoControlLabel 
           sType = "Label" 
       Case Is = MsoControlType.msoControlLabelEx 
           sType = "Label Ex" 
       Case Is = MsoControlType.msoControlOCXDropdown 
           sType = "OCX Dropdown" 
       Case Is = MsoControlType.msoControlPane 
           sType = "Pane" 
       Case Is = MsoControlType.msoControlPopup 
           sType = "Popup" 
       Case Is = MsoControlType.msoControlSpinner 
           sType = "Spinner" 
       Case Is = MsoControlType.msoControlSplitButtonMRUPopup 
           sType = "Split Button MRU Popup" 
       Case Is = MsoControlType.msoControlSplitButtonPopup 
           sType = "Split Button Popup" 
       Case Is = MsoControlType.msoControlSplitDropdown 
           sType = "Split Dropdown" 
       Case Is = MsoControlType.msoControlSplitExpandingGrid 
           sType = "Split Expanding Grid" 
       Case Is = MsoControlType.msoControlWorkPane 
           sType = "Work Pane" 
       Case Else 
           sType = "Unknown control type" 
   End Select 
   TranslateControlType = sType

End Function 

</source>


Working with Shortcut Menus

   <source lang="vb">

Sub ListShortCutMenus() 

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