|
楼主 |
发表于 2015-7-10 16:06
|
显示全部楼层
本帖最后由 守柔 于 2015-7-11 10:14 编辑
二、自定义功能区的实例对照
以下代码用于比照Excel 2003中的菜单开发,Excel 2007中自定义功能区的开发以及Ribbon Commander对于自定义功能区的开发。
示例目的:为Excel自定义一个工具栏或者选项卡,创建一组按钮,单击按钮以运行相应的宏。
1 Excel 2003下的自定义菜单
模块名:mdlExample
Option Explicit
Private Sub CustomUI2003()
''''创建自定义按钮
Dim myBar As Office.CommandBar
Dim myPopup As Office.CommandBarPopup
Dim myButton As Office.CommandBarButton
Dim vntButtonNames(1 To 4, 1 To 2) As Variant
Dim I As Integer
vntButtonNames(1, 1) = "Access"
vntButtonNames(2, 1) = "Outlook"
vntButtonNames(3, 1) = "PowerPoint"
vntButtonNames(4, 1) = "Word"
vntButtonNames(1, 2) = 264
vntButtonNames(2, 2) = 6225
vntButtonNames(3, 2) = 267
vntButtonNames(4, 2) = 42
Set myBar = Application.CommandBars.Add(Name:="Microsoft", Position:=msoBarTop, Temporary:=True) ''''创建工具栏
Set myPopup = myBar.Controls.Add(Type:=msoControlPopup) ''''创建子菜单
With myPopup
.Caption = "Office"
For I = 1 To 4
Set myButton = .Controls.Add(Type:=msoControlButton) ''''创建按钮
With myButton
.Caption = vntButtonNames(I, 1)
.Tag = vntButtonNames(I, 1)
.FaceId = vntButtonNames(I, 2)
.Style = msoButtonIconAndCaption
.OnAction = "mySub"
End With
Next
End With
myBar.Visible = True ''''显示工具栏
End Sub
Private Sub mySub()
Select Case UCase$(Application.CommandBars.ActionControl.Tag)
Case "ACCESS"
Application.ActivateMicrosoftApp xlMicrosoftAccess
Case "OUTLOOK"
Application.ActivateMicrosoftApp xlMicrosoftMail
Case "POWERPOINT"
Application.ActivateMicrosoftApp xlMicrosoftPowerPoint
Case "WORD"
Application.ActivateMicrosoftApp xlMicrosoftWord
End Select
End Sub
Private Sub RemoveMenu()
''''删除自定义工具栏
On Error Resume Next
Application.CommandBars("Microsoft").Delete
End Sub
运行结果如图 2所示。
CustomUI 2003
图 2 自定义菜单在Excel 2010中的截图
完成此功能约48行代码。
2 Excel 2007下的自定义功能区
2.1 XML代码
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" >
<ribbon>
<tabs>
<tab id="tabMicrosoft" label="Microsoft" >
<group id="groupOffice" label="Ms Office">
<gallery id="galOffice"
label="Office"
columns="1"
rows="10"
itemWidth="30"
itemHeight="32"
getItemCount="GetGalleryItemCount"
getItemLabel="GetGalleryItemLabel"
getItemImage="GetGalleryItemImage"
showItemImage="true"
showItemLabel="true"
size="normal" />
</group>
</tab>
</tabs>
</ribbon>
</customUI>
2.2 VBA中的回调
模块名:mdl2007
Private mvntNames As Variant ''''模块级变量,二维数组,储存按钮名称和图标
Private Sub GetGalleryItemCount(control As IRibbonControl, ByRef returnedVal)
''''Callback for galOffice getItemCount,回调,动态加载列表条目数量
If IsArray(mvntNames) = False Then LoadItemNames
returnedVal = UBound(mvntNames)
End Sub
Private Sub GetGalleryItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)
''''Callback for galOffice getItemLabel,回调,动态加载列表条目标签
returnedVal = mvntNames(index + 1, 1) ''''index索引从0开始
End Sub
Private Sub GetGalleryItemImage(control As IRibbonControl, index As Integer, ByRef returnedVal)
''''Callback for galOffice getItemImage,回调,动态加载列表条目图标
returnedVal = mvntNames(index + 1, 2) ''''index索引从0开始
End Sub
Private Sub mySub(control As IRibbonControl, id As String, index As Integer)
''''Callback for galOffice onAction,回调,单击列表条目时执行的过程
Select Case UCase$(index)
Case 0
Application.ActivateMicrosoftApp xlMicrosoftAccess
Case 1
Application.ActivateMicrosoftApp xlMicrosoftMail
Case 2
Application.ActivateMicrosoftApp xlMicrosoftPowerPoint
Case 3
Application.ActivateMicrosoftApp xlMicrosoftWord
End Select
End Sub
Private Sub LoadItemNames()
''''动态加载一个二维数组,用于指示加载的按钮名称和图标
ReDim mvntNames(1 To 4, 1 To 2)
mvntNames(1, 1) = "Access"
mvntNames(2, 1) = "Outlook"
mvntNames(3, 1) = "PowerPoint"
mvntNames(4, 1) = "Word"
mvntNames(1, 2) = "MicrosoftAccess"
mvntNames(2, 2) = "MicrosoftOutlook"
mvntNames(3, 2) = "MicrosoftPowerPoint"
mvntNames(4, 2) = IIf(Val(Application.Version) > 12, "MindMapExportWord", "FileSaveAsWordDocx")
End Sub
运行结果如图 3所示。
CustomUI 2007
图 3 自定义功能区在Excel 2010中的截图
完成此功能约需58行代码(XML+VBA)。
3 利用Ribbon Commander库生成自定义功能区
模块名:mdlRC
Option Explicit
''''引用 "IlvdaUK Ribbon Commander V1.1"
Private Sub CustomUIRC()
''''自定义功能区
Dim myUI As RibbonCommander.rxCustomUI
Dim myTab As RibbonCommander.rxTab
Dim myGroup As RibbonCommander.rxGroup
Dim myGallery As RibbonCommander.rxGallery
Dim oItem As RibbonCommander.rxItem
Dim astrNames(1 To 4, 1 To 2) As String
Dim I As Integer
astrNames(1, 1) = "Access"
astrNames(2, 1) = "Outlook"
astrNames(3, 1) = "PowerPoint"
astrNames(4, 1) = "Word"
astrNames(1, 2) = "MicrosoftAccess"
astrNames(2, 2) = "MicrosoftOutlook"
astrNames(3, 2) = "MicrosoftPowerPoint"
astrNames(4, 2) = IIf(Val(Application.Version) > 12, "MindMapExportWord", "FileSaveAsWordDocx")
Set myUI = RibbonCommander.rxCustomUI.Create("MS", "Example for RC", DispatchScope_global) ''''创建一个功能区(全局)
With myUI
.Clear ''''清空
Set myTab = .ribbon.tabs.Add(New rxTab) ''''创建一个Tab(选项卡)
myTab.Label = "MS"
Set myGroup = myTab.groups.Add(New rxGroup) ''''创建一个Group(组)
myGroup.Label = "Ms Office"
Set myGallery = myGroup.galleries.Add(New rxGallery) ''''创建一个Gallery(库)
With myGallery
.Label = "Office.RC"
.Columns = 1
.itemWidth = 30
.itemHeight = 32
.showImage = rxFalse
.OnAction = myUI.make_delegate("mySub3")
For I = 1 To UBound(astrNames, 1) ''''遍历数组行
Set oItem = .items.Add(New rxItem)
oItem.Label = astrNames(I, 1)
oItem.imageMso = astrNames(I, 2)
Next
End With
.Refresh ''''刷新功能区
End With
End Sub
Private Sub mySub3(control As IRibbonControl, id As String, index As Integer)
''''回调,单击列表条目时执行的过程
Select Case UCase$(index)
Case 0
Application.ActivateMicrosoftApp xlMicrosoftAccess
Case 1
Application.ActivateMicrosoftApp xlMicrosoftMail
Case 2
Application.ActivateMicrosoftApp xlMicrosoftPowerPoint
Case 3
Application.ActivateMicrosoftApp xlMicrosoftWord
End Select
End Sub
Private Sub RemoveCustomUI()
''''删除自定义功能区
On Error Resume Next
Dim oUI As RibbonCommander.rxCustomUI
For Each oUI In rxCustomUI.globalCustomUIs
If (oUI.contextId = "MS") Then rxCustomUI.globalCustomUIs.Remove oUI
Next
End Sub
运行结果如图 4所示。
CustomUI RC
图 4 自定义功能区在Excel 2010中的截图
完成此功能约需60行代码(XML+VBA)。
从上述几个实例对比,可以看出Ribbon Commander(RC)具有以下优点:
RC创建CustomUI时,完全脱离CustomUI.xml文件,直接在VBA中进行,所见即所得;
RC创建CustomUI的VBA代码写法,与Office 2003时的自定义工具栏极为相似。
另外,通过RC创建的CustomUI,具有大量的属性和方法,可以直接进行动态控制或者访问。
|
评分
-
1
查看全部评分
-
|