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

让我们说：

您的AutoExec宏执行函数Start_App()
您的表格中包含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应出现在组合框中

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

1 个答案: