Option Compare Database
Option Explicit
'----------------------------------------------------------
'modRibbonPublic模块 : 与Ribbon类配合使用
'相关 : clsRibbon类/clsRibbonControl类/modRibbonPrivate模块
' modOGL2007模块
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 获取功能区名称
' 功能区加载设置
' 加载功能区控件的图片
' 默认获取属性的方法
'----------------------------------------------------------
Public Ribbons As New Collection ' 全局功能区对象集合
Public ImagePath As String ' 默认功能区控件图片路径
'----------------------------------------------------------
'函数 : ActiveFormRibbonName
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 获取当前活动窗体的功能区名称
'
' 用于 onRibbonLoad 得到功能区的名称
'----------------------------------------------------------
Public Function ActiveFormRibbonName() As String
On Error Resume Next
ActiveFormRibbonName = Screen.ActiveForm.ribbonName
End Function
'----------------------------------------------------------
'函数 : ActiveReportName
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 获取当前活动报表的功能区名称
'
' 用于 onRibbonLoad 得到功能区的名称
'----------------------------------------------------------
Public Function ActiveReportRibbonName() As String
On Error Resume Next
ActiveReportRibbonName = Screen.ActiveReport.ribbonName
End Function
'----------------------------------------------------------
'函数 : ProjectRibbonName
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 获取当前项目的功能区名称
'
' 用于 onRibbonLoad 得到功能区的名称
'----------------------------------------------------------
Public Function ProjectRibbonName() As String
' Dim Obj As Object
' Const conPropNotFoundError = 3270
' Dim dbs As DAO.Database
'
' On Error GoTo ErrProjectRibbonName
' Set dbs = CurrentDb
ProjectRibbonName = CurrentProject.Properties!CustomRibbonID
Exit Function
ErrProjectRibbonName:
Resume Next
End Function
'----------------------------------------------------------
'过程 : onRibbonLoad
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 加载功能区的回调
'
' 作用于 :
' <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" OnLoad = "onRibbonLoad">
'----------------------------------------------------------
Public Sub onRibbonLoad(Ribbon As IRibbonUI)
On Error GoTo err_onRibbonLoad
Dim ribbonName As String
' 以当前活动的窗体、报表的功能名称作为功能区的名称
ribbonName = ActiveFormRibbonName() & ActiveReportRibbonName()
'默认全局功能区的名称
If ribbonName = "" Then ribbonName = ProjectRibbonName
Dim myRibbon As New clsRibbon '新建功能区对象
myRibbon.Name = ribbonName '设置名称
Set myRibbon.Ribbon = Ribbon '设置对象引用的功能区
Ribbons.Add myRibbon, ribbonName
On Error GoTo 0
Exit Sub
err_onRibbonLoad:
Debug.Print Err.Number, Err.Description, "onRibbonLoad", Err.Source
Resume Next
End Sub
'----------------------------------------------------------
'过程 : LoadImages
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 加载功能区时加载控件的图片
'
' 作用于 :
' <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" loadImage = "LoadImages">
' 加载
' <button id="btnMessage" label="最新消息" size="large" image="message.png" onAction="onButtonClick" />
' image 属性所指定的图片
'
' strImage : image 属性值
' Image : StdPicture, 返回值
'----------------------------------------------------------
Public Sub LoadImages(strImage As String, ByRef image)
'<button id="btnMessage" label="最新消息" size="large" image="message.png" onAction="onButtonClick" />
If strImage <> "" Then
If LCase(Left(strImage, 4)) = "mso." Then
image = Mid(strImage, 5)
Else
Dim sImgPath As String
If ImagePath = "" Then ImagePath = CurrentProject.Path & "\Pics"
sImgPath = ImagePath & "\" & strImage
Set image = LoadPictureGDIP(sImgPath)
End If
End If
End Sub
'----------------------------------------------------------
'过程 : GetVisible
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 设置功能区控件的可见性，由于功能区的回调函数中没有
' 功能区的名称，只能在功能区的回调函数中直接指定调用
' 的功能区的名称，从而才能从功能区控件集合中获得值。
'
' 作用于 :
' 功能区getVisible回调
' <labelControl id="labUnit" getVisible="Main_GetVisible" />
' modRibbonPrivate模块
' Public Sub Main_GetVisible(control As IRibbonControl, ByRef visible As Variant)
' Call GetVisible("Main", control, visible)
' End Sub
'----------------------------------------------------------
Public Sub GetVisible(ribbonName As String, control As IRibbonControl, ByRef Visible As Variant)
On Error GoTo ErrGetVisible
Visible = True
Visible = Ribbons(ribbonName).Controls(control.id).Visible
On Error GoTo 0
Exit Sub
ErrGetVisible:
Debug.Print Err.Number, Err.Description
Resume Next
End Sub
'----------------------------------------------------------
'过程 : GetEnable
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 设置功能区控件的可用性
'
' 作用于 :
' 功能区getEnable回调
' <button id="btnMessage" label="最新消息" size="large" image="message.png" getEnable="Main_GetEnable" onAction="onButtonClick" />
' modRibbonPrivate模块
' Public Sub Main_GetEnable(control As IRibbonControl, ByRef enabled As Variant)
' Call GetEnable("Main", control, enabled)
' End Sub
'----------------------------------------------------------
Public Sub GetEnable(ribbonName As String, control As IRibbonControl, ByRef Enabled As Variant)
On Error GoTo ErrGetEnabled
Enabled = True
Enabled = Ribbons(ribbonName).Controls(control.id).Enabled
On Error GoTo 0
Exit Sub
ErrGetEnabled:
Debug.Print Err.Number, Err.Description
Resume Next
End Sub
'----------------------------------------------------------
'过程 : GetLabel
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 设置功能区控件的标题
'
' 作用于 :
' 功能区getLabel回调
' <button id="btnMessage" size="large" image="message.png" getLabel="Main_GetLabel" />
' modRibbonPrivate模块
' Public Sub Main_GetEnable(control As IRibbonControl, ByRef label As Variant)
' Call GetEnable("Main", control, label)
' End Sub
'----------------------------------------------------------
Public Sub GetLabel(ribbonName As String, control As IRibbonControl, ByRef Label As Variant)
On Error GoTo ErrGetLabel
Label = ""
Dim lab As String
lab = Ribbons(ribbonName).Controls(control.id).Label
' If lab = "" Then
' Select Case control.id
' Case "labUnit": lab = "单位：" & PJ.UserUnit
' Case "labUser": lab = "用户：" & PJ.UserNick
' Case "labDate": lab = "今天是" & FormatDateTime(Date, vbLongDate)
' End Select
' End If
Label = lab
On Error GoTo 0
Exit Sub
ErrGetLabel:
Debug.Print Err.Number, Err.Description
Resume Next
End Sub
'----------------------------------------------------------
'过程 : GetImage
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 设置功能区控件的图片
'
' 作用于 :
' 功能区getImage回调
' <button id="btnMessage" size="large" getImage="Main_GetImage" tag="mso.HappyFace" />
' 其中tag指定控件的默认图片
' modRibbonPrivate模块
' Public Sub Main_GetImage(control As IRibbonControl, ByRef image)
' Call GetImage("Main", control, image)
' End Sub
'----------------------------------------------------------
Public Sub GetImage(ribbonName As String, control As IRibbonControl, ByRef image)
On Error GoTo ErrGetImage
Dim sImgName As String ' 图片文件名或Office图片名称
If Ribbons(ribbonName).Controls(control.id).image = "" Then
sImgName = control.tag
Else
sImgName = Ribbons(ribbonName).Controls(control.id).image
End If
If sImgName <> "" Then
If LCase(Left(sImgName, 4)) = "mso." Then
image = Mid(sImgName, 5)
Else
Dim sImgPath As String
If ImagePath = "" Then ImagePath = CurrentProject.Path & "\Pics"
sImgPath = ImagePath & "\" & sImgName
Set image = LoadPictureGDIP(sImgPath)
End If
End If
On Error GoTo 0
Exit Sub
ErrGetImage:
Debug.Print Err.Number, Err.Description
Resume Next
End Sub
