® MontaRibbons v.4.0

Public Function fncLoadRibbon()

Dim rsRib As DAO.Recordset
On Error GoTo fError
'-----------------------------------------------------------------
'This function loads the ribbons stored in the table tblRibbons,
'that must be called by the macro AutoExec

'
'Create the macro AutoExec, select the action RunCode

'and type the function name in the argument : fncLoadRibbon()
'------------------------------------------------------------------
Set rsRib = CurrentDb.OpenRecordset("tblRibbons", dbOpenDynaset)
Do While Not rsRib.EOF
  Application.LoadCustomUI rsRib!RibbonName, rsRib!RibbonXml
  rsRib.MoveNext
Loop
rsRib.Close
Set rsRib = Nothing

fExit:
  Exit Function
fError:
  Select Case Err.Number
    Case 3078
      MsgBox "Table not found...", vbInformation, "Warning"
    Case Else

      MsgBox "Error: " & Err.Number & vbCrLf & Err.Description, _

      vbCritical, "Warning", Err.HelpFile, Err.HelpContext
  End Select
  Resume fExit:
End Function

Public Function fncLoadRibbonXml()
Dim f As Long
Dim strText As String
Dim strOut As String
Dim rsXml As DAO.Recordset
On Error GoTo fError

'------------------------------------------------------------------------------
'This function loads the ribbons stored in the XML file,

'that must be called by the macro AutoExec.

'
'Create the macro AutoExec, select the action RunCode

'and type the function name in the argument: fncLoadRibbonXml()
'

'Create a table named tblRibbonsXml with the fields:

'RibbonName - In this field you stores the name you want to give to the ribbon

'RibbonXml - In this field you reports the Xml file name 
'
'This example assumes that you are with the XML files in

'the same place of your Database

'
'------------------------------------------------------------------------------
f = FreeFile
Set rsXml = CurrentDb.OpenRecordset("tblRibbonsXml", , dbOpenDynaset)
Do While Not rsXml.EOF
   Open CurrentProject.Path & "\" & rsXml!RibbonXml For Input As f

   Do While Not EOF(f)
      Line Input #f, strText
      strOut = strOut & strText & vbCrLf
   Loop

   Application.LoadCustomUI rsXml!RibbonName, strOut
   strOut = ""
   strText = ""
   f = FreeFile
   rsXml.MoveNext
Loop

fExit:
   Exit Function
fError:
   Select Case Err.Number
      Case 3078
         MsgBox "Table not found...", vbInformation, "Warning"
      Case Else
         MsgBox "Error: " & Err.Number & vbCrLf & Err.Description, _

         vbCritical, "Warning", Err.HelpFile, Err.HelpContext
   End Select
   Resume fExit:
End Function

<button
id = "btCostumers"
imageMso = "DistributionListSelectMembers"
label = "Customers"
onAction = "fncOnAction"
/>

Public Sub fncOnAction(control As IRibbonControl)

Select Case control.Id
   Case "btCustomers"
      Docmd.OpenForm "frmCustomers" 'Opens the customers form'
   Case Else
       MsgBox "You clicked the button " & control.Id, vbInformation, "Warning"
End Select

End Sub