VBA专题10-25：使用VBA操控Excel界面之一个示例程序

hercules028 2021-03-24

展开全文

excelperfect

在前面的一系列主题中，你已经学到了很多小的修改工作簿外观的VBA代码。下面，我们将介绍一个简单的示例程序，实现下面的功能特点：

1. 当打开工作簿时，

1.1 激活特定的工作表（名为Sample）。

1.2 开始的3行被冻洁。

1.3一个特定的行（行50）向上滚动并成为解冻窗格的顶部行。

1.4 活动工作表的滚动区域限制为某个单元格区域（A4:H100）。

1.5 一个自定义选项卡（名为Custom）被激活。

1.6 在运行时动态地使用项目（其标签为：AllGroups,Group1,Group2,Group3,Groups 1 and 2,Groups 1 and 3,和Groups 2 and3）填充一个下拉控件。

1.7 运行时使用图像动态地填充库控件。

2. 当用户从Custom选项卡的下拉控件中选择不同的项目时，

2.1 仅相应地显示选项卡中某组控件（AllGroups,Group1,Group2,Group3,Groups 1 and 2,Groups 1 and 3,或Groups 2 and3）。

2.2 状态栏显示当前选择的项目。

2.3 如果选择了指定的项目（例如Group2），那么激活指定的工作表（名为Sheet2），并对其外观作出下面的改变：

2.3.1 在页面布局视图中显示工作表

2.3.2 隐藏行和列标题

2.3.3 删除工作表中的网格线

2.3.4 隐藏公式栏

3. 如果激活的工作表是标准工作表，那么Custom选项卡是可见的。

4. 如果取消选取（或选取）指定的内置复选框（例如，在“视图”选项卡中的“编辑栏”复选框），那么禁用（或启用）自定义控件（例如，在“视图”选项卡中的G5B1按钮）。

5. 如果激活的工作表（名为Sheet1）具有指定的工作表级命名区域（例如，名为MyRange的单元格区域），那么启用Custom选项卡中不同组中的一组控件按钮。（例如，在Group 1中的G1B1，在Group 2中的G2B2，在Group 3中的G3B3，在Group 4中的G4B3）

6. 能够从单元格上下文菜单中访问自定义控件（名为Remove USD）。

要创建这个程序，执行下列步骤：

1. 创建一个新工作簿，将其保存为启用宏的工作簿。

2. 右击工作表选项卡，选择插入来添加一个图表工作表。

3. 重命名工作表为Sample、Sheet1和Sheet2。

4. 激活工作表Sheet1，选择一个单元格区域，在“名称”框中输入“Sheet1!MyRange”来命名为一个工作表级的名称。

5. 关闭该工作簿，然后在Custom UIEditor中打开该工作簿。

6. 在Custom UI Editor中，单击Insert|Office2010 Custom UI Part。

7. 复制并粘贴下面的XML代码：

8. 单击工具栏中的Validate按钮来检查是否有错误。

9. 保存并关闭该文件。

10. 在Excel中打开该文件。对于错误消息单击“确定”。

11. 按Alt+F11激活VBE。

12. 插入标准的VBA模块，复制并粘贴下列VBA代码：

Public myRibbon As IRibbonUI'库中图像的数量Dim ImageCount As Long'图像的文件名Dim ImageFilenames() As String'下拉项标签Dim ItemLabels(0 To 6) AsString'存储可见的组名Dim VisGrpNm1 As String'从下拉项中选择某项时Dim VisGrpNm2 As String 'customUI.onLoad回调Sub Initialize(ribbon AsIRibbonUI) Set myRibbon = ribbon '激活Custom选项卡 myRibbon.ActivateTab 'CustomTab' '不在在Workbook_Open中放置上面的代码行 '因为myRibbon仍然是Nothing '准备库图像的文件名 Call PrepareItemImages '准备下拉项的标签 Call PrepareItemLabelsEnd Sub Private Sub PrepareItemImages()'为库中的图像的文件名创建数组 Dim Filename As String Filename = Dir('C:\Photos\*.jpg') '遍历文件夹中的所有jpg文件 '使用jpg的文件名填充ImageFilenames数组 Do While Filename <> '' ImageCount = ImageCount + 1 ReDim Preserve ImageFilenames(1 ToImageCount) ImageFilenames(ImageCount) = Filename Filename = Dir Loop 'Dir() 返回一个零长字符串('') '当没有更多的文件在文件夹中时End Sub Private Sub PrepareItemLabels() '为下拉项创建项目标签数组 Dim i As Long ItemLabels(0) = 'All Groups' ItemLabels(1) = 'Group 1' ItemLabels(2) = 'Group 2' ItemLabels(3) = 'Group 3' ItemLabels(4) = 'Groups 1 and 2' ItemLabels(5) = 'Groups 1 and 3' ItemLabels(6) = 'Groups 2 and 3'End Sub 'ViewFormulaBar onAction回调SubMonitorViewFormulaBar(control As IRibbonControl, pressed As Boolean, ByRef cancelDefault) cancelDefault = False 'Restore thefunctionality of the control myRibbon.InvalidateControl 'G5B1'End Sub 'CustomTab getVisible回调Sub getVisibleCustomTab(controlAs IRibbonControl, ByRef CustomTabVisible) CustomTabVisible = TypeName(ActiveSheet) ='Worksheet'End Sub 'gallery1 onAction回调Sub SelectedPhoto(control AsIRibbonControl, id As String, index As Integer) MsgBox 'You selected Photo '& index + 1End Sub 'gallery1 getItemCount回调Sub getGalleryItemCount(controlAs IRibbonControl, ByRef Count) '指定调用getGalleryItemImage过程的次数 Count = ImageCountEnd Sub 'gallery1 getItemImage回调Sub getGalleryItemImage(controlAs IRibbonControl, index As Integer, ByRef Image) '每次调用本程序,index加1 Set Image = LoadPicture('C:\Photos\'& ImageFilenames(index + 1))End Sub 'dropDown1 onAction回调Sub SelectedItem(control AsIRibbonControl, id As String, index As Integer) '确定哪个组可见 VisGrpNm1 = '': VisGrpNm2 ='' Select Case index Case 0 VisGrpNm1 = '*' Case 1 VisGrpNm1 = '*1' Case 2 VisGrpNm1 = '*2' '如果选择第3项则改变Sheet2的外观 Call ChangeSheet2Appearance Case 3 VisGrpNm1 = '*3' Case 4 VisGrpNm1 = '*1' VisGrpNm2 = '*2' Case 5 VisGrpNm1 = '*1' VisGrpNm2 = '*3' Case 6 VisGrpNm1 = '*2' VisGrpNm2 = '*3' End Select '使Group1,Group2,和Group3无效 '执行invalidated,getVisibleGrp myRibbon.InvalidateControl'Group1' myRibbon.InvalidateControl'Group2' myRibbon.InvalidateControl'Group3' '更新状态栏 Application.StatusBar = 'Module:' & ItemLabels(index)End Sub 'dropDown1 getItemCount回调Sub getDropDownItemCount(control As IRibbonControl, ByRef Count) '指定下拉控件中项目总数 Count = 7End Sub 'dropDown1 getItemLabel回调Sub getDropDownItemLabel(control As IRibbonControl, index As Integer, ByRefItemLabel) '设置下拉控件中项目标签 ItemLabel = ItemLabels(index) '可替换,如果项目标签被存储在工作表Sheet1单元格区域A1:A7 '使用下面的代码: 'ItemLabel =Worksheets('Sheet1').Cells(index + 1, 1).ValueEnd Sub ' Group1getVisible回调Sub getVisibleGrp(control AsIRibbonControl, ByRef Enabled)'基于从下拉控件中选择的项'隐藏和取消隐藏1,2和3中的某个组 If control.id Like VisGrpNm1 Or control.idLike VisGrpNm2 Then Enabled = True 'Visible Else Enabled = False 'Hidden End IfEnd Sub Private Sub ChangeSheet2Appearance() Application.ScreenUpdating = False Sheets('Sheet2').Activate With ActiveWindow '在页面布局视图中显示当前工作表 .View = xlPageLayoutView '隐藏行和列标题 .DisplayHeadings = False '隐藏网格线 .DisplayGridlines = False End With '隐藏公式栏 Application.DisplayFormulaBar = False Application.ScreenUpdating = TrueEnd Sub ' G1B1onAction回调Sub MacroG1B1(control AsIRibbonControl) MsgBox 'MacroG1B1'End Sub ' G1B1getEnabled回调Sub getEnabledBs(control AsIRibbonControl, ByRef Enabled)'如果当前工作表具有命名区域MyRange' G1B1,G2B2,G3B3和G4B3按钮被启用'在程序中,当在Workbook_SheetActivate事件句柄中'Ribbon被无效时,本程序被调用Enabled = RngNameExists(ActiveSheet, 'MyRange')End Sub Function RngNameExists(ws AsWorksheet, RngName As String) As Boolean'返回是否在工作表中是否存在指定的命名区域 Dim rng As Range On Error Resume Next Set rng = ws.Range(RngName) RngNameExists = Err.Number = 0End Function ' G2B1onAction回调Sub MacroG2B1(control AsIRibbonControl) MsgBox 'MacroG2B1'End Sub ' G2B2onAction回调Sub MacroG2B2(control AsIRibbonControl) MsgBox 'MacroG2B2'End Sub 'G3B1onAction回调Sub MacroG3B1(control AsIRibbonControl) MsgBox 'MacroG3B1'End Sub ' G3B2onAction回调Sub MacroG3B2(control AsIRibbonControl) MsgBox 'MacroG3B2'End Sub ' G3B3onAction回调Sub MacroG3B3(control AsIRibbonControl) MsgBox 'MacroG3B3'End Sub ' G4B1onAction回调Sub MacroG4B1(control AsIRibbonControl) MsgBox 'MacroG4B1'End Sub ' G4B2onAction回调Sub MacroG4B2(control AsIRibbonControl) MsgBox 'MacroG4B2'End Sub ' G4B3onAction回调Sub MacroG4B3(control AsIRibbonControl) MsgBox 'MacroG4B3'End Sub ' G5B1onAction回调Sub MacroG5B1(control AsIRibbonControl) MsgBox 'MacroG5B1'End Sub ' G5B1getEnabled回调Sub getEnabledG5B1(control AsIRibbonControl, ByRef Enabled)'如果公式栏可见则启用G5B1按钮 Enabled = Application.DisplayFormulaBarEnd Sub Sub RemoveUSD(control AsIRibbonControl) Dim workRng As Range Dim Item As Range On Error Resume Next Set workRng = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) If Not workRng Is Nothing Then For Each Item In workRng If UCase(Left(Item, 3)) ='USD' Then Item = Right(Item, Len(Item) -3) End If Next Item End IfEnd Sub 13. 在ThisWorkbook模块中插入下面的VBA代码：Private Sub Workbook_Open() With Application '禁用Workbook_SheetActivate '因为myRibbon仍然是Nothing .EnableEvents = False .ScreenUpdating = False End With '激活特定的工作表 Worksheets('Sample').Activate '冻洁前3行 With ActiveWindow If .View = xlPageLayoutView Then .View = xlNormalView End If .SplitRow = 3 .SplitColumn = 0 .FreezePanes = True End With '在解除冻洁窗格中设置行50是顶行 ActiveWindow.ScrollRow = 50 '给用户的消息 With Range('A50') .Value = 'Scroll up to see otherinfo' .Font.Bold = True .Activate End With '为活动工作表设置滚动区域'限制在单元格区域A4:H100 ActiveSheet.ScrollArea ='A4:H100' With Application .EnableEvents = True .ScreenUpdating = True End WithEnd Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object)'使所有控件无效 myRibbon.InvalidateEnd Sub

14. 保存，关闭，然后在Excel中重新打开该工作簿。

上述代码的效果演示如下图：