Ribbon第二节：实战案例分享

xwLink1996

已于 2024-06-17 10:06:40 修改

阅读量539

点赞数 12

分类专栏： Ribbon 文章标签： ribbon excel microsoft xml 制造

于 2024-05-11 13:56:53 首次发布

本文链接：https://blog.csdn.net/nianfen/article/details/138712863

版权

Ribbon 专栏收录该内容

3 篇文章 1 订阅

订阅专栏

3.VBA的回调函数

Control                         Callback Name                   Signatures
(several controls)              getDescription                  Sub GetDescription(control As IRibbonControl, ByRef description)
(several controls)              getEnabled                      Sub GetEnabled(control As IRibbonControl, ByRef enabled)
(several controls)              getImage                        Sub GetImage(control As IRibbonControl, ByRef image)
(several controls)              getImageMso                     Sub GetImageMso(control As IRibbonControl, ByRef imageMso)
(several controls)              getLabel                        Sub GetLabel(control As IRibbonControl, ByRef label)
(several controls)              getKeytip                       Sub GetKeytip (control As IRibbonControl, ByRef label)
(several controls)              getSize                         sub GetSize(control As IRibbonControl, ByRef size)
(several controls)              getScreentip                    Sub GetScreentip(control As IRibbonControl, ByRef screentip)
(several controls)              getSupertip                     Sub GetSupertip(control As IRibbonControl, ByRef screentip)
(several controls)              getVisible                      Sub GetVisible(control As IRibbonControl, ByRef visible)
button                          getShowImage                    Sub GetShowImage (control As IRibbonControl, ByRef showImage)
button                          getShowLabel                    Sub GetShowLabel (control As IRibbonControl, ByRef showLabel)
button                          onAction – repurposed           Sub OnAction(control As IRibbonControl, byRef CancelDefault)
button                          onAction                        Sub OnAction(control As IRibbonControl)
checkBox                        getPressed                      Sub GetPressed(control As IRibbonControl, ByRef returnValue)
checkBox                        onAction                        Sub OnAction(control As IRibbonControl, pressed As Boolean)
comboBox                        getItemCount                    Sub GetItemCount(control As IRibbonControl, ByRef count)
comboBox                        getItemID                       Sub GetItemID(control As IRibbonControl, index As Integer, ByRef id)
comboBox                        getItemImage                    Sub GetItemImage(control As IRibbonControl, index As Integer, ByRef image)
comboBox                        getItemLabel                    Sub GetItemLabel(control As IRibbonControl, index As Integer, ByRef label)
comboBox                        getItemScreenTip                Sub GetItemScreenTip(control As IRibbonControl, index As Integer, ByRef screentip)
comboBox                        getItemSuperTip                 Sub GetItemSuperTip (control As IRibbonControl, index As Integer, ByRef supertip)
comboBox                        getText                         Sub GetText(control As IRibbonControl, ByRef text)
comboBox                        onChange                        Sub OnChange(control As IRibbonControl, text As String)
customUI                        loadImage                       Sub LoadImage(imageId As string, ByRef image)
customUI                        onLoad                          Sub OnLoad(ribbon As IRibbonUI)
dropDown                        getItemCount                    Sub GetItemCount(control As IRibbonControl, ByRef count)
dropDown                        getItemID                       Sub GetItemID(control As IRibbonControl, index As Integer, ByRef id)
dropDown                        getItemImage                    Sub GetItemImage(control As IRibbonControl, index As Integer, ByRef image)
dropDown                        getItemLabel                    Sub GetItemLabel(control As IRibbonControl, index As Integer, ByRef label)
dropDown                        getItemScreenTip                Sub GetItemScreenTip(control As IRibbonControl, index As Integer, ByRef screenTip)
dropDown                        getItemSuperTip                 Sub GetItemSuperTip (control As IRibbonControl, index As Integer, ByRef superTip)
dropDown                        getSelectedItemID               Sub GetSelectedItemID(control As IRibbonControl, ByRef index)
dropDown                        getSelectedItemIndex            Sub GetSelectedItemIndex(control As IRibbonControl, ByRef index)
dropDown                        onAction                        Sub OnAction(control As IRibbonControl, selectedId As String, selectedIndex As Integer)
dynamicMenu                     getContent                      Sub GetContent(control As IRibbonControl, ByRef content)
editBox                         getText                         Sub GetText(control As IRibbonControl, ByRef text)
editBox                         onChange                        Sub OnChange(control As IRibbonControl, text As String)
gallery                         getItemCount                    Sub GetItemCount(control As IRibbonControl, ByRef count)
gallery                         getItemHeight                   Sub getItemHeight(control As IRibbonControl, ByRef height)
gallery                         getItemID                       Sub GetItemID(control As IRibbonControl, index As Integer, ByRef id)
gallery                         getItemImage                    Sub GetItemImage(control As IRibbonControl, index As Integer, ByRef image)
gallery                         getItemLabel                    Sub GetItemLabel(control As IRibbonControl, index As Integer, ByRef label)
gallery                         getItemScreenTip                Sub GetItemScreenTip(control As IRibbonControl, index as Integer, ByRef screen)
gallery                         getItemSuperTip                 Sub GetItemSuperTip (control As IRibbonControl, index as Integer, ByRef screen)
gallery                         getItemWidth                    Sub getItemWidth(control As IRibbonControl, ByRef width)
gallery                         getSelectedItemID               Sub GetSelectedItemID(control As IRibbonControl, ByRef index)
gallery                         getSelectedItemIndex            Sub GetSelectedItemIndex(control As IRibbonControl, ByRef index)
gallery                         onAction                        Sub OnAction(control As IRibbonControl, selectedId As String, selectedIndex As Integer)
menuSeparator                   getTitle                        Sub GetTitle (control As IRibbonControl, ByRef title)
toggleButton                    getPressed                      Sub GetPressed(control As IRibbonControl, ByRef returnValue)
toggleButton                    onAction - repurposed           Sub OnAction(control As IRibbonControl, pressed As Boolean, byRef cancelDefault)
toggleButton                    onAction                        Sub OnAction(control As IRibbonControl, pressed As Boolean)

3.1 案例一：限定按钮使用的日期

这里是限定日期，通过getEnabled函数回调来设置按钮能否使用，可以用于设置权限，但是不能用于设置加密，因为UI可能会被打开篡改。

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
	<ribbon startFromScratch="false">
		<tabs>
			<tab idMso="TabHome">
				<group id="Group1" visible="true" label="汇总">
					<button id="button1" label="汇总上月资料" visible="true" getEnabled="ABC" imageMso="ControlLayoutStacked" size="large" onAction="Qather"/>
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

回调函数——getEnabled回调能否点击

'getEnabled函数的回调过程
Sub ABC(control As IRibbonControl, ByRef returnedVal)
    If Day(Date) >= 1 And Day(Date) <= 5 Then '如果打开文件的日期大于等于1而且小于等于3
        returnedVal = True                    '将变量赋值为true
    Else                                      '否则
        returnedVal = False                   '将变量赋值为false
    End If
End Sub

'单击id为button1的控件所执行的过程(仅展示命令按钮的设过程，忽略按钮对应的过程)
Sub Qather(control As IRibbonControl)
    MsgBox "数据汇总.......请补充代码", vbOKOnly, "友情提示"
End Sub

3.2 案例二：按下与弹起时切换图标

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="Intialize">
	<ribbon startFromScratch="false">
		<tabs>
			<tab id="Tab1" label="操作命令" insertBeforeMso="TabHome">
				<group id="Group1" label="零值控制" insertAfterMso="GroupViewShowHide">
					<toggleButton id="toggleButton1" label="显示零值" visible="true" enabled="true" onAction="zero" getImage="getImage" size="large" screentip="零值切换" supertip="按下时显示零值，弹起时不显示零值" keytip="L"/>
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

回调函数——getImage回调图标

Dim bl As Boolean    '声明一个公共变量，此变量代码切换按钮的状态
Dim rib As IRibbonUI '声明一个公共变量，IRibbonUI代表一个Ribbon类的对象实例
Sub Intialize(ribbon As IRibbonUI)
 '将IRibbonUI类赋予变量rib，从而载入缓存供以后调用。
 '通常是通过Invalidate或者InvalidateControl(controlID)方法调用，从而更新全部或者某个控件的值
  Set rib = ribbon
End Sub

'单击切换按钮时需要调用的过程，参数pressed代表按钮的状态
Sub zero(control As IRibbonControl, pressed As Boolean)
    '零值的显示状态由切换按钮的状态决定
    ActiveWindow.DisplayZeros = pressed
    '将按钮的状态赋值给变量bl,然后在“getImage”过程中根据bl的值决定按钮使用何种图标
    bl = pressed
    '强制更新功能区，否则不会执行过程“getImage”，不执行过程就不能载入图标
  rib.Invalidate
End Sub

'为切换按钮指定图标，其中参数returnedVal的值将传递给getImage函数
'getImage函数再将值传递给切换按钮，传递完成后按钮会更新屏幕上的显示图标
Sub getImage(control As IRibbonControl, ByRef returnedVal)
    If bl = False Then                     '如果公共变量bl的值等于false
        returnedVal = "DeclineInvitation"  '那么对参数returnedVal赋值为DeclineInvitation
    Else                                   '否则
        returnedVal = "AcceptInvitation"   '对参数returnedVal赋值为AcceptInvitation
    End If
  
End Sub

'以上三个过程中将首先执行过程“Intialize”，它在开启工作簿时就会执行
'然后，当单击切换按钮时，会执行过程“zero”
'由于在过程“zero”中会更新功能区，即代码“rib.Invalidate”的作用，
'所以它会接着执行过程“getImage”，每更新一次功能区，调用一次“getImage”过程

3.3 案例三：显示Sheet中图形数量的标签

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="Intialize">
	<ribbon startFromScratch="false">
		<tabs>
			<tab idMso="TabHome">
				<group id="Group1" label="图形对象数量">
					<labelControl id="Label1" getLabel="getLabel"/>
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

回调函数——getLabel回调标签

Public rib As IRibbonUI '声明一个公共变量，IRibbonUI代表一个Ribbon类的对象实例
Sub Intialize(ribbon As IRibbonUI)
 '将IRibbonUI类赋予变量rib，从而载入缓存供以后调用。
  Set rib = ribbon
End Sub

'使用回调函数getLabel获取工作表中的图形对象的数量，然后回传给标签控件
'参数returnedVal表示回传给标签的值，对其赋值即可
Sub getLabel(control As IRibbonControl, ByRef returnedVal)
returnedVal = ActiveSheet.Shapes.Count  '将活动工作表中的图形对象数量赋值给参数returnedVal
End Sub

3.4 案例四：通过编辑框执行精确查找

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
	<ribbon startFromScratch="false">
		<tabs>
			<tab idMso="TabHome">
				<group id="group1" label="快速查找" insertBeforeMso="GroupFont">
					<dropDown id="Style" showLabel="true" label="匹配方式" onAction="dropDownChange">
						<item id="xlWhole" label="xlWhole" imageMso="WatchWindow"/>
						<item id="xlPart" label="xlPart" imageMso="ZoomPrintPreviewExcel"/>
					</dropDown>
					<editBox id="FindTxt" label="查找内容" imageMso="ZoomPrintPreviewExcel" sizeString="999999999999" maxLength="30" visible="true" showLabel="true" onChange="editBoxChange" keytip="R"/>
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

回调函数——带text参数

Public str As String    '声明一个公共变量
'单击下拉控件时执行的过程，有三个参数，第一参数代表控件本身，第二参数代表选择的子项的id
'第三参数代表选择的子项的序号
Sub dropDownChange(control As IRibbonControl, id As String, index As Integer)
    str = id    '将选择的子项的id传递给变量Str
End Sub
'单击文字框时执行的过程。有两个参数，第二参数代表文字框中显示的文本
Sub editBoxChange(control As IRibbonControl, text As String)
    If Len(text) = 0 Then Exit Sub              '如果文字框空白则中断程序
    If str = "" Then MsgBox "请设置 lookat参数": Exit Sub '如果公共变量空白则提示且结束过程
    Dim FirstCell As Range, rng As Range        '声明变量
    With Cells
        '执行查找，匹配方式由变量Str决定
        Set FirstCell = .Find(text, LookIn:=xlValues, lookat:=IIf(str = "xlWhole", xlWhole, xlPart))
        If Not FirstCell Is Nothing Then        '如果已找到
            firstAddress = FirstCell.Address    '记录第一个目标的位置
            Do                                  '循环查找其它目录
                If rng Is Nothing Then Set rng = FirstCell Else Set rng = Union(rng, FirstCell)
                Set FirstCell = .FindNext(FirstCell) '查找下一个
            Loop While FirstCell.Address <> firstAddress
        End If
    End With
    If Not rng Is Nothing Then                  '如果找到
        rng.Select                              '选择所有对象
    Else                                        '否则提示未找到
        MsgBox "Sorry,未找到“" & text & "”"
    End If
End Sub

3.5 案例五：组的标签显示日期

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
	<ribbon startFromScratch="false">
		<tabs>
			<tab idMso="TabHome">
				<group id="group1" getLabel="getLabel" insertBeforeMso="GroupFont">
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

回调函数——getLabel回调标签，回调日期

'为组添加文字，包括“您好”及当前日期和星期
Sub getLabel(control As IRibbonControl, ByRef returnedVal)
 returnedVal = "您好 " & Format(Date, "yyyy-mm-dd AAAA")
End Sub

3.6 案例六：创建图片库

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
	<ribbon>
		<tabs>
			<tab idMso="TabHome">
				<group id="group1" label="合并单元格" insertAfterMso="GroupClipboard">
					<gallery id="gallery1" label="合并单元格" size="large" showLabel="true" imageMso="TableStyleClear" columns="1" rows="2" itemHeight="157" itemWidth="142" supertip="合并单元格且保留所有数据" getItemCount="getItemCount" getItemID="getItemID" getItemImage="getItemImage" getItemSupertip="getItemSupertip" getItemLabel="getItemLabel" onAction="Action"/>
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

回调函数——多个

'加载同路径下的jpg图片
'图片名称必须是1.jpg和2.jpg,与当前文件放在同一个路径下
Sub getItemImage(control As IRibbonControl, Index As Integer, ByRef returnedVal)
    Set returnedVal = LoadPicture(ThisWorkbook.Path & "\" & Index + 1 & ".jpg")
End Sub
'将库的子项目数量设置为2
Sub getItemCount(control As IRibbonControl, ByRef returnedVal)
    returnedVal = 2
End Sub
'指定库的每一个子项的ID
Sub getItemID(control As IRibbonControl, Index As Integer, ByRef Id)
    Id = Index + 1
End Sub
'指定每一子项目的提示信息，由于项目有多个，需要使用数组
Sub getItemSupertip(control As IRibbonControl, Index As Integer, ByRef supertip)
    supertip = Array("将数组合并居中，但是保留所有合并前的数据", "取消合并居中，还原合并前的状态，不丢失数据")(Index)
End Sub
'指定图片右边显示的文本标签
Sub getItemLabel(control As IRibbonControl, Index As Integer, ByRef returnedVal)
    returnedVal = Array("合并居中", "取消合并")(Index)
End Sub
'单击库的子项时执行的宏过程
Sub Action(control As IRibbonControl, Id As String, Index As Integer)
Call 合并居中(Index)
End Sub
Sub 合并居中(Style)
    On Error Resume Next
    If TypeName(Selection) <> "Range" Then MsgBox "请选择单元格！", 65, "提示 ": Exit Sub
    Dim i As Integer, rng_count, str, ans As String, rng As Range, j
    Set rng = Intersect(Selection, ActiveSheet.UsedRange)
    If rng Is Nothing Then Exit Sub  '如果选区与已用区域不存在交集则退出程序
    If rng.count = 1 Then Exit Sub  '如果选区仅仅是一个单元格则退出程序
    ans = Application.InputBox("请输入分隔符，可以空白", "确定分隔符", "-", , , , , 2)  '指定分隔符
    If ans = "False" Then Exit Sub    '如果按了取消键则退出程序
    ans = ans & Chr(28)   '将分隔符添加一个后缀，该后缀是一个看不到的符号
    Application.ScreenUpdating = False    '关闭屏幕更新
    Application.DisplayAlerts = False    '关闭提示
    If Style = 0 Then    '如果选择"是"，即合并
        rng.MergeCells = False  '取消原有合并（假设有合并的话）
        rng_count = rng.count  '获取选区个数
        j = rng.Columns.count  '获取选区列数
        str = rng(1)    '提取选区第一个单元格的值
        For i = 2 To rng_count    '从第二个单元格开始循环到选区最后一个单元格
            If i Mod j = 0 Then  '如果变量i是j的倍数（即选区最后一列）
                str = str & Chr(3400) & IIf(Len(rng(i)) = 0, "", ans) & rng(i) & Chr(10)         '将串连的文本中间添加一个符号chr(3400)及分隔符（如果单元格是空白
                '则不使用分隔符），且在最后添加一个换行符
            ElseIf i Mod j = 1 Then    '如果是选区的第一列
                str = str & Chr(3400) & rng(i)    '将字符串与符号chr(3400)连接
            Else    '如果既不是第一列也不是最后一列
                '将字符串与chr(3000)连接，且在中间插入前面指定的分隔符（如果单元格是空白则不使用分'隔符）
                str = str & Chr(3400) & IIf(Len(rng(i)) > 0, ans, "") & rng(i)
            End If
        Next
        With rng
            .MergeCells = True              '合并选区
            .HorizontalAlignment = xlCenter    '左右居中
            .VerticalAlignment = xlCenter   '上下居中
            .NumberFormatLocal = "@"      '定义数字格式为"文本"
            .Value = Left(str, Len(str) - 1)      '将前面串连的文本去除最后一个字符后写入合并单元格
            .WrapText = True              '自动换行
        End With
    Else    '如果选择"取消合并"
        If rng.MergeCells Then    '如果单元格处于合并状态
            '如果单元格中不存在chr(3400)，则不是通过本工具合并的单元格，所以不能取消合并
            If InStr(rng(1).Text, Chr(3400)) = 0 Then MsgBox "本合并单元格不能恢复！": GoTo endd
            '如果合并区域中不存在输入的分隔符，则退出程序
            If InStr(rng(1).Text, ans) = 0 Then MsgBox "输入的分隔符不存在！": GoTo endd
            rng.MergeCells = False    '取消合并
            Dim rngg As Range, tet As String
            '如果合并时的字符串中有指定的分隔符，且与符号chr(340)连在一起，则删除它
            tet = Replace(ActiveCell.Text, Chr(3400) & ans, Chr(3400))    '
            tet = Replace(tet, Chr(10), "")   '将换行符替换成空白
            For Each rngg In rng    '遍历选区中所有单元格
                rngg = Split(tet, Chr(3400))(i)    '
                i = i + 1
            Next rngg
        End If
    End If
endd:
    Application.DisplayAlerts = True   '恢复提示
    Application.ScreenUpdating = True    '恢复屏幕更新
End Sub

3.7 案例七：点击下拉栏切换Sheet

动态设置下拉栏数量

Dim rib As IRibbonUI, xlApplication As MyEvent  '声明变量
Sub auto_Open()  '开启工作簿时执行
  Set xlApplication = New MyEvent  '声明类，从而触发类模块中的应用程序级事件
  Set xlApplication.xlApp = Application  '将Excel应用程序赋值给MyEvent类中的xlApp，从而可以通过xlApp执行应用程序级事件
End Sub
Sub ribbonLoaded(ribbon As IRibbonUI)
  Set rib = ribbon  '将功能区的ribbon对象赋值给变量rib
End Sub
Sub Refresh()
  On Error Resume Next  '当程序出错时继续执行下一句
  rib.Invalidate     '更新功能区的控件，本例中是更新工作表目录
End Sub
Sub ItemCount(control As IRibbonControl, ByRef returnedVal)
  returnedVal = Worksheets.Count  '将工作表数量赋予参数returnedVal
End Sub
Sub ListItem(control As IRibbonControl, index As Integer, ByRef returnedVal)
  returnedVal = Worksheets(index + 1).Name  '将工作表的名称赋予参数returnedVal。因为参数Index的值是从0开始的，而工作表数量的下限是1，因此要加1
End Sub
Sub Action(control As IRibbonControl, ID As String, index As Integer)
  On Error Resume Next  '当程序出错时继续执行下一句
  Worksheets(index + 1).Select  '选择第index+1个工作表
End Sub

对应UI

<customUI onLoad="ribbonLoaded" xmlns="http://schemas.microsoft.com/office/2006/01/customui">
	<ribbon startFromScratch="false">
		<tabs>
			<tab id="Tab1" label="操作命令" insertBeforeMso="TabHome">
				<group id="List" label="工作表目录" insertBeforeMso="GroupPageSetup">
					<dropDown id="Sheets" label="单击切换" getItemCount="ItemCount" getItemLabel="ListItem" onAction="Action"/>
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

4.其他调整

4.1禁用内置功能

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
	<commands>
		<command idMso="FileSaveAs" enabled="false"/>
		<command idMso="MergeCenterMenu" enabled="false"/>
		<command idMso="Copy" enabled="false"/>
		<command idMso="Cut" enabled="false"/>
	</commands>
</customUI>

持续更新中，欢迎加微信交流xwlink1996......