顶级ps技术:创建自定义工具栏示例-

在《RibbonX: Customizing the Office 2007 Ribbon》的第1章，介绍了一个在Excel 2003及以前版本中定制工具栏的很好的示例，现辑录于此，与大家分享。
首先，在VBE中，插入一个类模块，并命名为clsEvents，输入下面的代码：

'声明应用程序事件Public WithEvents appXL As ApplicationPublic WithEvents drop As Office.CommandBarComboBox Private Sub appXL_SheetActivate(ByVal Sh As Object)Dim ws As WorksheetDim Wb As WorkbookDim i  As Long On Error GoTo Err_HandlerSet Wb = ActiveWorkbookIf Not Wb.Name = ThisWorkbook.Name Then Exit Sub'初始化复选框    Set g_cmdbarcboBox = g_cmdBar.FindControl(Type:=msoControlDropdown, Tag:="MyList")g_cmdbarcboBox.Clear'添加复选框项目,即工作表名称    For Each ws In Sh.Parent.Sheetsg_cmdbarcboBox.AddItem ws.NameNextFor i = 1 To g_cmdbarcboBox.ListCountIf g_cmdbarcboBox.List(i) = Sh.Name Then g_cmdbarcboBox.ListIndex = i: Exit ForNextCall drop_Change(g_cmdbarcboBox)Exit SubErr_Handler:ErrHandle ErrEnd Sub Private Sub appXL_WorkbookActivate(ByVal Wb As Workbook)Set g_cmdbarcboBox = g_cmdBar.FindControl(Type:=msoControlDropdown, Tag:="MyList")If Wb.Name = ThisWorkbook.Name Theng_cmdbarcboBox.Enabled = TrueappXL_SheetActivate Wb.ActiveSheetElse:Call deleleteControlsg_cmdbarcboBox.Enabled = FalseEnd IfExit SubErr_Handler:ErrHandle ErrEnd Sub Public Sub setDrop(box As Office.CommandBarComboBox)'设置复选框对象    Set drop = boxEnd Sub  Private Sub drop_Change(ByVal Ctrl As Office.CommandBarComboBox)'如果选择的复选框文本为工作表名称,则创建相应的菜单    Select Case UCase(Ctrl.Text)Case "SUPPLIERS"Call setMNUSUPPLIERSCase "CUSTOMERS"Call setMNUCUSTOMERSCase "ACCOUNTS"Call setMNUACCOUNTSCase ElseCall deleleteControlsEnd SelectEnd Sub

然后，添加标准模块，输入下面的代码：

'声明全局变量Public Const gcstrCMDBARNAME    As String = "DYNAMIC MENU"Public Const gcstrMNUSUPPLIERS  As String = "Suppliers"Public Const gcstrMNUCUSTOMERS  As String = "Customers"Public Const gcstrMNUACCOUNTS   As String = "Accounts" Public g_cmdBar                 As CommandBarPublic g_cmdbarMenu             As CommandBarPopupPublic g_cmdbarBtn              As CommandBarButtonPublic g_cmdbarcboBox           As CommandBarComboBoxPublic gcls_appExcel            As New clsEventsPublic gcls_cboBox              As New clsEvents Sub wsBuildMenus()Call wsDeleteMenusOn Error GoTo Err_Handler'添加工具栏,并设置尺寸    Set g_cmdBar = CommandBars.Add(gcstrCMDBARNAME, msoBarFloating)g_cmdBar.Width = 150'添加复选框    Set g_cmdbarcboBox = g_cmdBar.Controls.Add(Type:=msoControlDropdown)'设置复选框标签以便程序中识别    '设置复选框操作过程    With g_cmdbarcboBox.Tag = "MyList".OnAction = "selectedSheet".Width = 150End With'添加帮助按钮    Set g_cmdbarBtn = g_cmdBar.Controls.Add(Type:=msoControlButton)With g_cmdbarBtn.Caption = "帮助".OnAction = "runHelp".Style = msoButtonIconAndCaption.FaceId = 984End With'设置应用程序级事件并传递复选框对象    Set gcls_appExcel.appXL = Applicationgcls_cboBox.setDrop g_cmdbarcboBoxWith g_cmdBar.Visible = True.Protection = msoBarNoChangeDock + msoBarNoResizeEnd WithExit SubErr_Handler:ErrHandle ErrEnd Sub '删除菜单工具栏Sub wsDeleteMenus()On Error Resume NextApplication.CommandBars(gcstrCMDBARNAME).DeleteSet g_cmdBar = NothingSet g_cmdbarMenu = NothingSet g_cmdbarBtn = NothingSet g_cmdbarcboBox = NothingSet gcls_appExcel = NothingSet gcls_cboBox = NothingEnd Sub '删除工具栏中的菜单项Sub deleleteControls()On Error Resume Nextg_cmdBar.Controls(gcstrMNUACCOUNTS).Deleteg_cmdBar.Controls(gcstrMNUCUSTOMERS).Deleteg_cmdBar.Controls(gcstrMNUSUPPLIERS).DeleteEnd Sub '设置复选框中选中项目后的操作,即激活与项目名称相同的工作表Sub selectedSheet()Dim g_cmdbarcboBox As CommandBarComboBoxOn Error Resume NextSet g_cmdbarcboBox = CommandBars.FindControl(Type:=msoControlDropdown, Tag:="MyList")ActiveWorkbook.Sheets(g_cmdbarcboBox.Text).ActivateEnd Sub '设置选择相应工作表后,出现在工具栏中的菜单Sub setMNUACCOUNTS()Call deleleteControlsOn Error GoTo Err_HandlerSet g_cmdbarMenu = g_cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)g_cmdbarMenu.Caption = gcstrMNUACCOUNTSSet g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)g_cmdbarBtn.Caption = "New Account"Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)g_cmdbarBtn.Caption = "Delete account"Exit SubErr_Handler:ErrHandle ErrEnd Sub Sub setMNUSUPPLIERS()Call deleleteControlsOn Error GoTo Err_HandlerSet g_cmdbarMenu = g_cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)g_cmdbarMenu.Caption = gcstrMNUSUPPLIERSSet g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)g_cmdbarBtn.Caption = "New Supplier"Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)g_cmdbarBtn.Caption = "Current data"Exit SubErr_Handler:ErrHandle ErrEnd Sub Sub setMNUCUSTOMERS()Call deleleteControlsOn Error GoTo Err_HandlerSet g_cmdbarMenu = g_cmdBar.Controls.Add(Type:=msoControlPopup, BEFORE:=2)g_cmdbarMenu.Caption = gcstrMNUCUSTOMERSSet g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)g_cmdbarBtn.Caption = "New Customer"Set g_cmdbarBtn = g_cmdbarMenu.Controls.Add(Type:=msoControlButton)g_cmdbarBtn.Caption = "Outstanding parts"Exit SubErr_Handler:ErrHandle ErrEnd Sub Sub ErrHandle(ByVal objError As ErrObject)MsgBox objError.Description, vbCritical, objError.NumberCall wsDeleteMenusEnd Sub Sub runHelp()ActiveWorkbook.FollowHyperlink "http://www.excelperfect.com", NewWindow:=True, AddHistory:=TrueEnd Sub

最后，编写ThisWorkbook模块代码，以便在工作簿打开时执行创建工具栏的操作，在工作簿关闭时删除自定义工具栏。

Private Sub Workbook_Open()Call wsBuildMenusEnd Sub Private Sub Workbook_BeforeClose(Cancel As Boolean)Call wsDeleteMenusEnd Sub

至此，代码全部编写完成。保存后，关闭该工作簿。再重新打开工作簿，如果没有选择与创建工具栏菜单名称相同的工作表，则会出现下面的工具栏：

如果选择的复选框项目与创建工具栏菜单的工作表名相同，则会出现下面的工具栏：