访问：通过 VBA 加载并应用自定义功能区

Question

我需要为 RunTime 用户设置一些按钮。

我创建了 USysRibbon 表，插入了 XML 并通过数据库选项进行了测试。一切正常。

但我需要通过 VBA 自定义函数加载自定义功能区。该函数将通过 AutoExec 宏执行（在用户登录并设置用户 ID 作为临时变量后）。

请帮助我创建简单的 VBA 来调用 LoadCustomUI 函数并从表中获取 XML（该表中为 ID、RibbonName 和 RibbonXML）并应用于用户界面。

谢谢你。

Answer 1

我假设您已经像这样创建了功能区表：http://www.accessribbon.de/en/?Access_-_Ribbons:Load_Ribbons_Into_The_Database:..._Using_The_System_Table_USysRibbons

比方说：

1. 您的 AutoExec 宏执行该函数

   Start_App()

2. 您的表中有一条 RibbonName="MyRibbon1" 的记录

使用以下代码创建模块

' This variable handle your ribbon name, so if you have several Ribbons in your table, you adapt this constant to match the current Ribbon

Public Const APP_RIBBON As String = "MyRibbon1"


Public Function Start_app()

    On Error GoTo Err_Handler

    LoadRibbons

    ' do anything else you need in the Start_app    

Exit_Sub:
    Exit Function

Err_Handler:
    If Err.Number > 0 Then
        MsgBox Err.DESCRIPTION, vbExclamation, "An error " & Err.Number & " occured !"
        Debug.Print Err.Number
        Resume Exit_Sub
    End If

End Function


Private Function LoadRibbons()

        On Error GoTo Error1

        Dim RS As dao.Recordset

        Set RS = CurrentDB.OpenRecordset("SELECT * FROM USysRibbon ")

     Do Until RS.EOF

         If RS("RibbonName").value = APP_RIBBON Then
              ' Ribbon found: Load it and exit
            Application.LoadCustomUI APP_RIBBON, RS("RibbonXML").value
            Exit Do
        End If

         RS.MoveNext

     Loop

Error1_Exit:

     On Error Resume Next
     RS.Close
     Set RS = Nothing
     Exit Function

Error1:

     Select Case Err
         Case 32609
         ' Ribbon already loaded, do nothing and exit
     Case Else
         MsgBox "Error: " & Err.Number & vbCrLf & Err.DESCRIPTION, vbCritical, "Error", Err.HelpFile, Err.HelpContext
     End Select

     Resume Error1_Exit

 End Function

请注意，您还有另一件事要做：第一次运行代码时，功能区将不会显示。您必须进入 选项 / 当前数据库，然后在组合框中

Ribbon Name:

选择功能区。如果您运行过一次代码，您的 MyRibbon1 应该出现在组合框中

Answer 2

为了更改当前数据库选项中的功能区名称，只需使用以下命令：

CurrentDb.Properties("CustomRibbonID") = Me.theRibbon

theRibbon

是

usysRibbons

表

中的功能区名称

Answer 3

它可以工作，但要使其处于活动状态，数据库似乎需要关闭并重新打开 我想根据用户登录来更改功能区