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
