onActionを =OptionOnClick() としているのでOfficeObjectLibraryの参照はなくてもいい。
2010で製造時14.0を参照していても、2007が12.0に読み替えてるから(思い込みじゃないか)、コールバックでもいい。
2007はofficeMenu/2010はbackStageを振り分ける。contextualTabsもあったかな。
カレントデータベースのリボン名を予め設定
AutoExecでCreateRibbonを実行
今のところ無事作動。
とはいえ、あんまり使えないか。ソースコードありきの互換性だし。
#if vba6 = 1 then
const flg = 0
#else
const flg = -1
#end if
にして、a2007でaccde化したらa2010(32)でも動くかもしれん。
Option Compare Database
Option Explicit
#If VBA7 = 1 Then
Const flg = -1
#Else
Const flg = 0
#End If
Public Function OptionOnClick()
MsgBox "OptionButtonClick"
End Function
Function CreateRibbon()
On Error GoTo ErrHnd
Dim xdoc As New DOMDocument
Dim xelem(10) As IXMLDOMElement
Set xelem(0) = xdoc.createElement("customUI")
If flg Then
xelem(0).setAttribute "xmlns", "http://schemas.microsoft.com/office/2009/07/customui"
Else
xelem(0).setAttribute "xmlns", "http://schemas.microsoft.com/office/2006/01/customui"
End If
xdoc.appendChild xelem(0)
Set xelem(1) = xdoc.createElement("commands")
xelem(0).appendChild xelem(1)
Set xelem(2) = xdoc.createElement("command")
xelem(2).setAttribute "idMso", "ApplicationOptionsDialog"
xelem(2).setAttribute "onAction", "=OptionOnClick()"
xelem(1).appendChild xelem(2)
Set xelem(1) = xdoc.createElement("ribbon")
xelem(1).setAttribute "startFromScratch", "true"
xelem(0).appendChild xelem(1)
' Debug.Print xdoc.XML
Application.LoadCustomUI "backoffice", xdoc.XML
Done:
Exit Function
ErrHnd:
If Err.Number <> 32609 Then MsgBox Err.Number & vbCrLf & Err.Description
End Function
0 件のコメント:
コメントを投稿