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

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

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 PrepareItemLabels
End 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
    '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 + 1
End Sub
'gallery1 getItemCount回调
Sub getGalleryItemCount(controlAs IRibbonControl, ByRef Count)
    '指定调用getGalleryItemImage过程的次数
    Count = ImageCount
End 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 = 7
End 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).Value
End Sub
' Group1getVisible回调
Sub getVisibleGrp(control AsIRibbonControl, ByRef Enabled)
'基于从下拉控件中选择的项
'隐藏和取消隐藏1,2和3中的某个组
    If control.id Like VisGrpNm1 Or control.idLike VisGrpNm2 Then
        Enabled = True 'Visible
        Enabled = False 'Hidden
    End If
End 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 = True
End 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 = 0
End 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.DisplayFormulaBar
End 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 If
End 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 With
End Sub