VBA/Excel/Access/Word/Application/CommandBar

Материал из VB Эксперт
Версия от 12:46, 26 мая 2010; Admin (обсуждение | вклад) (1 версия)
(разн.) ← Предыдущая | Текущая версия (разн.) | Следующая → (разн.)
Перейти к: навигация, поиск

Содержание

Add a new commandbar

 
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



Add ControlButton to CommandBar

 
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



Adding a control to a command bar

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



Add PopupControl to CommandBar

 
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



Adjusting a control"s Visible property

 
Sub ToggleAllToolbars()
    For Each cb In CommandBars
        If cb.Type = msoBarTypeNormal Then
            cb.Visible = Not cb.Visible
        End If
    Next cb
End Sub



Attaching a drop-down list to a command bar

 
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



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

 
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



CommandBar Object

 
Sub CommandBarCount()
   MsgBox "There are " & CommandBars.count & " command bars"
End Sub



CommandBars collection

 
Sub com()
    MsgBox CommandBars(1).Name
End Sub



Counting custom toolbars

 
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



Create Shortcut

 
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



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

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



Creating a Toolbar: AddRemoveButton

 
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



Creating a Toolbar and assign its action

 
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



Creating a Toolbar and display MsgBox in its action

 
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



Custom Toolbars

 
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



deletes a control that has a caption of SortButton.

 
Sub commandBar()
    CommandBars("MyToolbar").Controls("SortButton").Delete
End Sub



Determines if a given command bar name exists

 
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



Display Control Detail

 
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



display shortcut menu with the ShowPopup method

 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    CommandBars("MyShortcut").ShowPopup
    Cancel = True
End Sub



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

 
Sub Test()
    MsgBox CommandBars(3).Controls(1).Caption
End Sub



Finding Visible Controls with FindControls

 
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



Get the type of CommandBars

 
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



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

 
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



Inspecting a CommandBar

 
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



Listing all controls on all toolbars

 
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



Listing the controls on a command bar

 
Sub ShowControlCaptions()
    Dim myCommandBar As commandBar
    Set myCommandBar = CommandBars("Standard")
    For Each ctl In myCommandBar.Controls
        Debug.Print ctl.Caption
    Next ctl



Properties of CommandBar controls

 
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



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

 
Sub Test2()
    MsgBox CommandBars("Standard").Controls("New").Caption
End Sub



Referring to command bars

 
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



Removes a toolbar specified by the name passed in

 
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



Removing all toolbars and then restoring them

 
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



Replacing Excel"s built-in menu with your own

 
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



Reset CommandBar

 
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



Restores the Worksheet Menu Bar to its native state

 
Private Sub ResetCommandBar() 
    Application.rumandBars("Worksheet Menu Bar").Reset 
End Sub



Restore tool bar

 
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



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

 
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



Set Control style, Action, group, faceid and caption

 
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



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

 
Sub faceID()
    CommandBars("MyToolbar").Controls(1).FaceId = 45
End Sub



Show All Toolbar Controls

 
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



Show CommandBar Names

 
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



show/hide check symbol

 
Sub MenuCommand2_OnAction()
  With CommandBars.ActionControl
    If .State = msoButtonDown Then
      .State = msoButtonUp
    Else
      .State = msoButtonDown
    End If
  End With
End Sub



Shows or hides a command bar.

 
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



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

 
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



The custom toolbar is removed with this procedure

 
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



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

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



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

 
Sub commdBar()
    CommandBars("MyToolbar").Protection = msoBarNoCustomize
End Sub



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

 
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



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

 
Sub delBar()
    CommandBars("MyToolbar").Controls(1).Delete
End Sub



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

 
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



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

 
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



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

 
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



Working with Shortcut Menus

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