access2010 ribbonUI テストコード

'Form
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
    rbn01.CreateRibbon
    Me.RibbonName = rbn01.rbnName
End Sub

'module:rbn01
Option Compare Database
Option Explicit

Public Const rbnName = "rbn01"

Private rbn As IRibbonUI

Public Function Onload(ribbon As IRibbonUI)
    Set rbn = ribbon
End Function

Sub CreateRibbon()
    If Not rbn Is Nothing Then Exit Sub

On Error GoTo ErrHnd
    
    Dim xdoc As New DOMDocument
    Dim xelem(10) As IXMLDOMElement
    Dim i As Integer, j As Integer

    Set xelem(0) = xdoc.createElement("customUI")
    xelem(0).setAttribute "xmlns", "http://schemas.microsoft.com/office/2009/07/customui"
    xelem(0).setAttribute "onLoad", "Onload"
    xdoc.appendChild xelem(0)
    

    Set xelem(1) = xdoc.createElement("ribbon")
    xelem(1).setAttribute "startFromScratch", "true"
    xelem(0).appendChild xelem(1)
    
    Set xelem(2) = xdoc.createElement("tabs")
    xelem(1).appendChild xelem(2)
    
    For j = 0 To 8
        Set xelem(3) = xdoc.createElement("tab")
        xelem(3).setAttribute "id", "tab" & Format(j, "00")
        xelem(3).setAttribute "label", "タブ" & Format(j, "00")
        xelem(2).appendChild xelem(3)
        
        Set xelem(4) = xdoc.createElement("group")
        xelem(4).setAttribute "id", "group" & Format(j, "00")
        xelem(4).setAttribute "label", "グループ" & Format(j, "00")
        xelem(3).appendChild xelem(4)
        
        For i = j * 1000 To (j + 1) * 1000 - 1
            Set xelem(5) = xdoc.createElement("button")
            xelem(5).setAttribute "id", "button" & Format(i, "0000")
            xelem(5).setAttribute "label", "B" & Format(i, "0000")
            xelem(5).setAttribute "imageMso", "HappyFace"
            xelem(4).appendChild xelem(5)
        Next
    Next
'    Debug.Print xdoc.XML
    
    Application.LoadCustomUI rbnName, xdoc.XML
Done:
    Exit Sub
ErrHnd:
    If Err.Number <> 32609 Then MsgBox Err.Number & vbCrLf & Err.Description
End Sub