第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

 

 

转载于:https://www.cnblogs.com/csl-office-vb-sql-net/archive/2010/01/21/1653256.html