訪問：通過VBA加載和應用自定義功能區

Question

我需要爲RunTime用戶設置一些按鈕。

我創建了USysRibbon表，插入了XML並通過數據庫選項進行了測試。一切正常。

但我需要通過VBA自定義函數加載自定義功能區。此函數將通過AutoExec宏執行（在用戶登錄和用戶標識爲temp變量後）。

請幫助我創建簡單的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宏與RibbonName =執行功能Start_App()
2. 您的表中的記錄「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應該出現在組合框中