19.1 掌握好命令栏
代码清单19.1: 列出申请CommandBar
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
'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
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
'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
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
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程序
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
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查找可见控件
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
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: 创建一个菜单栏
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
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的可见性
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
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: 基于工作表菜单构件过程
![](https://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif)
'代码清单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
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