第19章 控制好命令栏

19.1 掌握好命令栏

代码清单19.1: 列出申请CommandBar

 

'代码清单19.1: 列出申请CommandBar
'List all of the command bars on a worksheet named inventory
Sub Inventory()
    Dim cb As CommandBar
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("Inventory").Cells(2, 1)
    
    'loop through all the command bars in excel
    For Each cb In Application.CommandBars
        rg.Value = cb.Name
        rg.Offset(0, 1).Value = cb.Index
        rg.Offset(0, 2).Value = cb.BuiltIn
        rg.Offset(0, 3).Value = cb.Enabled
        rg.Offset(0, 4).Value = cb.Visible
        rg.Offset(0, 5).Value = TranslateCommandBarType(cb.Type)
        rg.Offset(0, 6).Value = TranslateCommandBarPosition(cb.Position)
        rg.Offset(0, 7).Value = cb.Controls.Count
            
        Set rg = rg.Offset(1, 0)
    Next
    
    Set rg = Nothing
    Set cb = Nothing
End Sub

'translates a msoBarType enumeration into a text description
'of the bar type.
Function TranslateCommandBarType(vType As MsoBarType) As String
    Dim sType As String
    
    Select Case vType
        Case MsoBarType.msoBarTypeMenuBar
            sType = "Menu Bar"
        Case MsoBarType.msoBarTypeNormal
            sType = "Normal"
        Case MsoBarType.msoBarTypePopup
            sType = "Popup"
        Case Else
            sType = "Unknown type"
    End Select
    TranslateCommandBarType = sType
End Function

'translates a msoBarPosition enumeration into a text description
'of the bar position
Function TranslateCommandBarPosition(vType As MsoBarPosition) As String
    Dim sPosition As String
    
    Select Case vType
        Case MsoBarPosition.msoBarBottom
            sPosition = "Bottom"
        Case MsoBarPosition.msoBarFloating
            sPosition = "Floating"
        Case MsoBarPosition.msoBarLeft
            sPosition = "Left"
        Case MsoBarPosition.msoBarMenuBar
            sPosition = "MenuBar"
        Case MsoBarPosition.msoBarPopup
            sPosition = "Popup"
        Case MsoBarPosition.msoBarRight
            sPosition = "Right"
        Case MsoBarPosition.msoBarTop
            sPosition = "Top"
        Case Else
            sType = "Unknown Position"
    End Select
    TranslateCommandBarPosition = sPosition
End Function

 

代码清单19.2: 生效一个CommandBar

 

'代码清单19.2: 生效一个CommandBar
'Tests CommandBarExists and ShowCommandBar
Sub TestCommandBarUtilities()
    Debug.Print CommandBarExists("Worksheet Menu Bar")
    Debug.Print CommandBarExists("Formatting")
    Debug.Print CommandBarExists("Not a command bar")
    
    ShowCommandBar "Borders", True
End Sub

'Determines if a given command bar name exists
Function CommandBarExists(sName As String) As Boolean
    Dim s As String
    On Error GoTo bWorksheetExistsErr
    
    s = Application.CommandBars(sName).Name
    CommandBarExists = True
    Exit Function
bWorksheetExistsErr:
    CommandBarExists = False
End Function

'Shows or hides a command bar. you do not need
'to validate sName before using this procedure.
'Depends on CommandBarExists function.
Sub ShowCommandBar(sName As String, bShow As Boolean)
    If CommandBarExists(sName) Then
        Application.CommandBars(sName).Visible = bShow
    End If
End Sub

 

 

19.2 CommandBar反应

代码清单19.3: 检查一个CommandBar

 

'代码清单19.3: 检查一个CommandBar
Sub InspectCommandBar(cb As CommandBar, rgOutput As Range)
    DisplayGeneralInfo cb, rgOutput
    Set rgOutput = rgOutput.End(xlDown).Offset(2, 0)
    DisplayControlDetail cb, rgOutput
    
End Sub

Sub DisplayGeneralInfo(cb As CommandBar, rgOutput As Range)
    rgOutput.Value = "Name: "
    rgOutput.Offset(0, 1).Value = cb.Name
    
    rgOutput.Offset(1, 0).Value = "Index: "
    rgOutput.Offset(1, 1).Value = cb.Index
    
    rgOutput.Offset(2, 0).Value = "Built In: "
    rgOutput.Offset(2, 1).Value = cb.BuiltIn
    
    rgOutput.Offset(3, 0).Value = "Enabled: "
    rgOutput.Offset(3, 1).Value = cb.Enabled
    
    rgOutput.Offset(4, 0).Value = "Visible: "
    rgOutput.Offset(4, 1).Value = cb.Visible
    
    rgOutput.Offset(5, 0).Value = "Type: "
    rgOutput.Offset(5, 1).Value = TranslateCommandBarType(cb.Type)
    
    rgOutput.Offset(6, 0).Value = "Position: "
    rgOutput.Offset(6, 1).Value = TranslateCommandBarPosition(cb.Position)
    
    rgOutput.Offset(7, 0).Value = "Control Count: "
    rgOutput.Offset(7, 1).Value = cb.Controls.Count
    
    With rgOutput.Resize(8, 1)
        .Font.Bold = True
        .HorizontalAlignment = xlRight
    End With
End Sub

Sub DisplayControlDetail(cb As CommandBar, rgOutput As Range)
    Dim cbc As CommandBarControl
    
    On Error Resume Next
    
    
    'make column header
    rgOutput.Value = "Description"
    rgOutput.Offset(0, 1).Value = "Caption"
    rgOutput.Offset(0, 2).Value = "Index"
    rgOutput.Offset(0, 3).Value = "Built In?"
    rgOutput.Offset(0, 4).Value = "Enabled?"
    rgOutput.Offset(0, 5).Value = "Visible?"
    rgOutput.Offset(0, 6).Value = "Priority Dropped?"
    rgOutput.Offset(0, 7).Value = "Priority"
    rgOutput.Offset(0, 8).Value = "Type"
    rgOutput.Offset(0, 9).Value = "Control Count"
    rgOutput.Offset(0, 10).Font.Bold = True
    
    Set rgOutput = rgOutput.Offset(1, 0)
    'Get control detail
    For Each cbc In cb.Controls
        
        rgOutput.Value = Replace(cbc.Caption, "&", "")
        rgOutput.Offset(0, 1).Value = cbc.Caption
        rgOutput.Offset(0, 2).Value = cbc.Index
        rgOutput.Offset(0, 3).Value = cbc.BuiltIn
        rgOutput.Offset(0, 4).Value = cbc.Enabled
        rgOutput.Offset(0, 5).Value = cbc.Visible
        rgOutput.Offset(0, 6).Value = cbc.IsPriorityDropped
        rgOutput.Offset(0, 7).Value = cbc.Priority
        rgOutput.Offset(0, 8).Value = TranslateCommandBarType(cbc.Type)
        rgOutput.Offset(0, 9).Value = cbc.Controls.Count
        
        Set rgOutput = rgOutput.Offset(1, 0)
    Next
    
    'Clean up.
    Set cbc = Nothing
End Sub

'Translates a MsoControlType enumeration into a text description of the control type.
Function TranslateControlType(vType As MsoControlType) As String
    Dim sType As String
    
    Select Case vType
        Case MsoControlType.msoControlActiveX
            sType = "ActiveX"
        Case MsoControlType.msoControlAutoCompleteCombo
            sType = "AutoCompleteCombo"
        Case MsoControlType.msoControlButton
            sType = "Button"
        Case MsoControlType.msoControlButtonDropdown
            sType = "ButtonDropdown"
        Case MsoControlType.msoControlButtonPopup
            sType = "ButtonPopup"
        Case MsoControlType.msoControlComboBox
            sType = "ComboBox"
        Case MsoControlType.msoControlCustom
            sType = "Custom"
        Case MsoControlType.msoControlDropdown
            sType = "Dropdown"
        Case MsoControlType.msoControlEdit
            sType = "Edit"
        Case MsoControlType.msoControlExpandingGrid
            sType = "ExpandingGrid"
        Case MsoControlType.msoControlGauge
            sType = "Gauge"
        Case MsoControlType.msoControlGenericDropdown
            sType = "GenericDropdown"
        Case MsoControlType.msoControlGraphicCombo
            sType = "GraphicCombo"
        Case MsoControlType.msoControlGraphicDropdown
            sType = "GraphicDropdown"
        Case MsoControlType.msoControlGraphicPopup
            sType = "GraphicPopup"
        Case MsoControlType.msoControlGrid
            sType = "Label"
        Case MsoControlType.msoControlLabel
            sType = "Label"
        Case MsoControlType.msoControlLabelEx
            sType = "LabelEx"
        Case MsoControlType.msoControlOCXDropdown
            sType = "OCXDropdown"
        Case MsoControlType.msoControlPane
            sType = "Pane"
        Case MsoControlType.msoControlPopup
            sType = "Popup"
        Case MsoControlType.msoControlSpinner
            sType = "Spinner"
        Case MsoControlType.msoControlSplitButtonMRUPopup
            sType = "SplitButtonMRUPopup"
        Case MsoControlType.msoControlSplitButtonPopup
            sType = "SplitButtonPopup"
        Case MsoControlType.msoControlSplitDropdown
            sType = "SplitDropdown"
        Case MsoControlType.msoControlSplitExpandingGrid
            sType = "SplitExpandingGrid"
        Case MsoControlType.msoControlWorkPane
            sType = "WorkPane"
        Case Else
            sType = "unkown control type"
    End Select
    TranslateControlType = sType
End Function

 

代码清单19.4: 将组合框键入到InspectCommandBar程序

 

'代码清单19.4: 将组合框键入到InspectCommandBar程序
Sub choCommandBars_Change()
    'make sure the correct worksheet is active, changing
    'the name of other worksheets can trigger
    'this event unexpectedly.
    If ActiveSheet.Name = Me.Name Then
        'clear the details associated with the
        'previous command bar
        Me.Range("A14:J65536").ClearContents
        
        'inspect the command bar
        InspectCommandBar Application.CommandBars(Me.Range("CommandBar").Value), Me.Range("A4")
        
    End If
End Sub

 

 

19.3 可以弯曲的CommandBarControl对象

代码清单19.5: 使用FindControls查找可见控件

 

'代码清单19.5: 使用FindControls查找可见控件
Sub ShowVisibleControls()
    FindVisibleControls ThisWorkbook.Worksheets("FindControl").Range("FoundControls").Offset(1, 0)
End Sub

'displays information on all visible controls
Sub FindVisibleControls(rg As Range)
    Dim ctrls As CommandBarControls
    Dim ctrl As CommandBarControl
    
    Set ctrls = Application.CommandBars.FindControls(, , , True)
    
    For Each ctrl In ctrls
        rg.Value = ctrl.Parent.Name
        rg.Offset(0, 1).Value = ctrl.Caption
        rg.Offset(0, 2).Value = ctrl.Index
        rg.Offset(0, 3).Value = ctrl.ID
        rg.Offset(0, 4).Value = ctrl.Enabled
        rg.Offset(0, 5).Value = ctrl.Visible
        rg.Offset(0, 6).Value = ctrl.IsPriorityDropped
        rg.Offset(0, 7).Value = TranslateControlType(ctrl.Type)
        
        Set rg = rg.Offset(1, 0)
    Next
    
    Set ctrl = Nothing
    Set ctrls = Nothing
End Sub

 

 

19.4 精心编制自定义命令栏

代码清单19.6: 创建一个菜单栏

 

'代码清单19.6: 创建一个菜单栏
Sub AddMenuItemExample()
    Dim cbWSMenuBar As CommandBar
    Dim cbc As CommandBarControl
    
    Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
    
    'Add a menu item
    Set cbc = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, temporary:=True)
    
    'set its tag so it can be easily found and referred to in VBA
    cbc.Tag = "MyMenu"
    
    With cbc
        .Caption = "&My Menu"
        
        With .Controls.Add(Type:=msoControlButton, temporary:=True)
            .Caption = "Item &1"
            .OnAction = "Thisworkbook.sayhello"
            .Tag = "Item 1"
        End With
        
        With .Controls.Add(Type:=msoControlButton, temporary:=True)
            .Caption = "Item &2"
            .OnAction = "Thisworkbook.sayhello"
            .Tag = "Item 2"
        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 = "Item 4"
        End With
        
        With .Controls.Add(Type:=msoControlButton, temporary:=True)
            .Caption = "Item &5"
            .OnAction = "Thisworkbook.sayhello"
            .Tag = "Item 5"
            .BeginGroup = True
        End With        
        
        With .Controls.Add(Type:=msoControlButton, temporary:=True)
            .Caption = "Item &6"
            .OnAction = "Thisworkbook.sayhello"
            .Tag = "Item 6"
        End With        
    End With
End Sub

Sub SayHello()
    MsgBox "Hello", vbOKOnly
End Sub

'Restores the worksheet Menu bar to its native state
Sub ResetCommandBar()
    Application.CommandBars("Worksheet Menu Bar").Reset    
End Sub

 

代码清单19.7: 控制一个CommandBarControl的可见性

 

'代码清单19.7: 控制一个CommandBarControl的可见性
Sub SetVisibilityExample()
    Dim vResponse As Variant
    
    vResponse = MsgBox("do you want to show mymenu item?", vbYesNo)
    
    If vResponse = vbYes Then
        SetControlVisibility "MyMenu", True
    Else
        SetControlVisibility "MyMenu", False
    End If    
End Sub

Sub SetControlVisibility(sTag As String, IsVisible As Boolean)
    Dim cbc As CommandBarControl
    Set cbc = Application.CommandBars.FindControl(, , sTag)
    
    If Not cbc Is Nothing Then
        cbc.Visible = IsVisible
    End If
    
    Set cbc = Nothing
End Sub

 

代码清单19.8: 基于工作表菜单构件过程

 

'代码清单19.8: 基于工作表菜单构件过程
Const NA = "N/A"

Const TAG_OFFSET = 1
Const CAPTION_OFFSET = 2
Const TYPE_OFFSET = 3
Const ONACTION_OFFSET = 4
Const BEGINGROUP_OFFSET = 5
Const DESCRIPTION_OFFSET = 6

Sub BuildMenu()
    Dim ws As Worksheet
    Dim rg As Range
    
    On Error GoTo ErrHandler
    
    Set ws = ThisWorkbook.Worksheets("Menu Builder")
    
    'start on second row because the first row
    'contains column headers
    Set rg = ws.Cells(2, 1)
    
    Do Until IsEmpty(rg)
        If rg.Value = NA Then
            'new top level menu item
            AddTopLevelItem rg
        Else
            'sub-item of existing control
            AddSubItem rg
        End If
        
        'move down to the next row
        Set rg = rg.Offset(1, 0)
    Loop
    
ExitPoint:
    Set rg = Nothing
    Set ws = Nothing
    Exit Sub
ErrHandler:
    Debug.Print Err.Description
    Resume ExitPoint
End Sub

Function AddTopLevelItem(rg As Range) As CommandBarControl
    Dim cbWSMenuBar As CommandBar
    Dim cbc As CommandBarControl
    
    On Error GoTo ErrHandler
    
    Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
    
    'Add a menu item
    Set cbc = cbWSMenuBar.Controls.Add(msoControlPopup, , , , True)
    cbc.Tag = rg.Offset(0, TAG_OFFSET).Value
    cbc.DescriptionText = rg.Offset(0, DESCRIPTION_OFFSET).Value
    cbc.Caption = rg.Offset(0, CAPTION_OFFSET).Value
    
    'return the newly added menu item
    Set AddTopLevelItem = cbc

ExitPoint:
    Set cbc = Nothing
    Set cbWSMenuBar = Nothing
    Exit Function
ErrHandler:
    Set AddTopLevelItem = Nothing
    Resume ExitPoint
End Function

Function AddSubItem(rg As Range) As CommandBarControl
    Dim cbcParent As CommandBarControl
    Dim cbc As CommandBarControl
    
    On Error GoTo ErrHandler
    
    'Locate parent based on parent tag
    Set cbcParent = Application.CommandBars.FindControl(, , rg.Value)
    
    If Not cbcParent Is Nothing Then
    'add a menu item
    Set cbc = cbcParent.Controls.Add(GetType(rg))
    
    'make sure the item has an OnAction value
    'other than na.
    If rg.Offset(0, ONACTION_OFFSET).Value <> NA Then
    cbc.OnAction = rg.Offset(0, ONACTION_OFFSET).Value
    End If
    
    cbc.Tag = rg.Offset(0, TAG_OFFSET).Value
    cbc.DescriptionText = rg.Offset(0, DESCRIPTION_OFFSET).Value
    cbc.Caption = rg.Offset(0, CAPTION_OFFSET).Value
    cbc.BeginGroup = rg.Offset(0, BEGINGROUP_OFFSET).Value
    
    'return the newly added control
    Set AddSubItem = cbc
    Else
    'can't find parent control - return nothing
    Set AddSubItem = Nothing
    End If
    
ExitPoint:
    Set cbc = Nothing
    Set cbcParent = Nothing
    Exit Function
ErrHandler:
    Debug.Print Err.Description
    Resume ExitPoint
End Function

'converts selected msoControlType enumerations to values
Function GetType(rg As Range) As Long
    Dim sType As String
    
    sType = rg.Offset(0, TYPE_OFFSET).Value
    
    Select Case sType
        Case "msoControlPopup"
            GetType = MsoControlType.msoControlPopup
        Case "msoControlButton"
            GetType = MsoControlType.msoControlButton
        Case "msoControlDropdown"
            GetType = MsoControlType.msoControlDropdown
        Case Else
            GetType = MsoControlType.msoControlPopup
    End Select
End Function

Sub DeleteMyMenu2()
    DeleteMenu "MyMenu2"
End Sub

Sub DeleteMyMenu3()
    DeleteMenu "MyMenu3"
End Sub

Sub DeleteMenu(sTag As String)
    Dim cbc As CommandBarControl
    
    Set cbc = Application.CommandBars.FindControl(Tag:=sTag)
    
    If Not cbc Is Nothing Then
        cbc.Delete
    End If
    
    Set cbc = Nothing
End Sub