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
'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
'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
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
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
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
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