In this post, we will be briefly explaining the code for this Ribbon:
You fill first need to create a table called USysRibbons that contains a ID(AutoNumber), RibbonName(Text) and RibbonXML(Memo) fields.
Do not close the table when created! Instead, change it to datasheet view and click on create form.
Save the form as frmRibbon.
Enlarge the RibbonXML field.
Save the form and change it to Form view. Paste the code below into the RibbonXML field and write RibbonAdmin in the RibbonName field. Save the database.
The Code
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon startFromScratch="true">
<tabs>
<tab id="tabHome" label="Home" visible="true">
<group id="GroupInfo" label="Info">
<labelControl id="lblDate" getLabel="onGetLabel"/>
<labelControl id="lblUser" getLabel="onGetLabel"/>
<labelControl id="lblTerminal" getLabel="onGetLabel"/>
</group>
<group id="GroupHome" label="Home">
<button id="cmdHome" label="Home" imageMso="BlogHomePage"
size="large" onAction="onClick"/>
</group>
<group id="GroupNavigation" label="Navigation">
<splitButton id="sbStudents" size="large">
<button id="cmdStudents" imageMso="AddOrRemoveAttendees"
label="Students" onAction="onClick"/>
<menu id="menStudents">
<button id="cmdStudentsNew" label="New Student" onAction="onClick" imageMso="DiagramShapeInsertClassic" />
<button id="cmdStudentsEdit" label="Edit Student" onAction="onClick" imageMso="DataFormSource" />
<button id="cmdStudentsReports" label="Reports" onAction="onClick" imageMso="DefinedPrintStyle"/>
</menu>
</splitButton>
<separator id="separator1"/>
<splitButton id="sbTeachers" size="large">
<button id="cmdTeachers" imageMso="AccessTableContacts"
label="Teachers" onAction="onClick"/>
<menu id="menTeachers">
<button id="cmdTeachersNew" label="New Teacher" onAction="onClick" imageMso="DiagramShapeInsertClassic"/>
<button id="cmdTeachersEdit" label="Edit Teacher" onAction="onClick" imageMso="DataFormSource"/>
<button id="cmdTeachersReports" label="Reports" onAction="onClick" imageMso="DefinedPrintStyle"/>
< /menu>
</splitButton>
<separator id="separator2"/>
<splitButton id="sbCourses" size="large">
<button id="cmdCourses" imageMso="ReadingMode"
label="Courses" onAction="onClick"/>
<menu id="menCourses">
<button id="cmdCoursesNew" label="New Course" onAction="onClick" imageMso="DiagramShapeInsertClassic"/>
<button id="cmdCoursesEdit" label="Edit Course" onAction="onClick" imageMso="DataFormSource"/>
</menu>
</splitButton>
<separator id="separator3"/>
<splitButton id="sbClasses" size="large">
<button id="cmdClasses" imageMso="MeetingsWorkspace"
label="Classes" onAction="onClick"/>
<menu id="menClasses">
<button id="cmdClassTimeTable" label="TimeTable" onAction="onClick" imageMso="StartAfterPrevious"/>
<button id="cmdClassCalendar" label="Calendar" onAction="onClick" imageMso="DateAndTimeInsert"/>
<button id="cmdClassRegister" label="Register" onAction="onClick" imageMso="AddressBook"/>
<button id="cmdClassLogAttendance" label="Log Attendance" onAction="onClick"
imageMso="DateAndTimeInsert"/>
<button id="cmdClassAttendanceReport" label="Attendance Report" onAction="onClick"
imageMso="CopyToPersonalContacts"/>
</menu>
</splitButton>
</group>
<group id="GroupClasses" label="Today's Classes">
< labelControl id="lblTest" label="Please choose a class:"/>
< dropDown
id="drpClasses"
keytip="& amp;TN"
label="Classes:"
screentip="View classes"
sizeString="WWWWWWWWWWW"
tag="TS"
getItemCount="OnGetItemCount"
getItemID="OnGetItemID"
getItemLabel="OnGetItemLabel"
onAction="OnSelectItem"/>
< /group>
</tab>
</tabs>
</ribbon>
</customUI>
The XML Explained (briefly)
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">...</customUI>
Here we informing Access that the code is XML.
<ribbon startFromScratch="true">
This means that we want to create a whole new Ribbon and not build on the existing Ribbon.
< tabs> ... < /tabs>
This code will contain the tabs.
< tab id="tabHome" label="Home" visible="true"> ... < /tab>
All code that goes here will be in the Home tab.
< group id="GroupInfo" label="Info">
< labelControl id="lblDate" getLabel="onGetLabel"/>
< labelControl id="lblUser" getLabel="onGetLabel"/>
< labelControl id="lblTerminal" getLabel="onGetLabel"/>
< /group>
This code will display a group called Info. Within the group, three labels will be shown and the captions within the labels are custom text generated when the Ribbon is loaded.
< group id="GroupHome" label="Home">
< button id="cmdHome" label="Home" imageMso="BlogHomePage"
size="large" onAction="onClick"/>
< /group>
This code will display a group called Home along with a button called Home. The imageMSO=”BlogHomePage” statement is responsible for the image whilst the onAction=”onClick” statement is responsible for automating the button.
< group id="GroupNavigation" label="Navigation">
< splitButton id="sbStudents" size="large">
< button id="cmdStudents" imageMso="AddOrRemoveAttendees"
label="Students" onAction="onClick"/>
< menu id="menStudents">
< button id="cmdStudentsNew" label="New Student" onAction="onClick" imageMso="DiagramShapeInsertClassic" />
< button id="cmdStudentsEdit" label="Edit Student" onAction="onClick" imageMso="DataFormSource" />
< button id="cmdStudentsReports" label="Reports" onAction="onClick" imageMso="DefinedPrintStyle"/>
< /menu>
< /splitButton>
< separator id="separator1"/>
< splitButton id="sbTeachers" size="large">
< button id="cmdTeachers" imageMso="AccessTableContacts"
label="Teachers" onAction="onClick"/>
< menu id="menTeachers">
< button id="cmdTeachersNew" label="New Teacher" onAction="onClick" imageMso="DiagramShapeInsertClassic"/>
< button id="cmdTeachersEdit" label="Edit Teacher" onAction="onClick" imageMso="DataFormSource"/>
< button id="cmdTeachersReports" label="Reports" onAction="onClick" imageMso="DefinedPrintStyle"/>
< /menu>
< /splitButton>
< separator id="separator2"/>
< splitButton id="sbCourses" size="large">
< button id="cmdCourses" imageMso="ReadingMode"
label="Courses" onAction="onClick"/>
< menu id="menCourses">
< button id="cmdCoursesNew" label="New Course" onAction="onClick" imageMso="DiagramShapeInsertClassic"/>
< button id="cmdCoursesEdit" label="Edit Course" onAction="onClick" imageMso="DataFormSource"/>
< /menu>
< /splitButton>
This code will display a group called Navigation along with four split buttons. The split buttons and associated menus all have their own images and onClick events.
< group id="GroupClasses" label="Today's Classes">
< labelControl id="lblTest" label="Please choose a class:"/>
< dropDown
id="drpClasses"
keytip="& amp;TN"
label="Classes:"
screentip="View classes"
sizeString="WWWWWWWWWWW"
tag="TS"
getItemCount="OnGetItemCount"
getItemID="OnGetItemID"
getItemLabel="OnGetItemLabel"
onAction="OnSelectItem"/>
< /group>
This code displays a group called Today’s Classes and displays a drop down menu within it. When a drop down menu item is selected the onAction=”OnSelectionItem” code runs.
Now for the VBA code.
You will need to create a module called modRibbonCallbacks and drop this code in it:
Option Compare Database
Public Sub onGetLabel(control As IRibbonControl, ByRef label)
'-----------------Other Labels--------------------------------
Select Case control.id
Case "lblDate"
label = FormatDateTime(Date, vbLongDate)
Case "lblUser"
label = getAccessUserName()
Case "lblTerminal"
label = getComputerName()
End Select
End Sub
Public Sub OnClick(control As IRibbonControl)
Select Case control.id
'---------------------------------------------------
'---------------------------------------------------
'----------------Home---------------------------
Case "cmdHome"
CloseAllFormsAndReports
OpenSingleform "frmHome", Edit, Normal
'---------------------------------------------------
'---------------------------------------------------
'----------------Students---------------------------
Case "cmdStudents"
OpenSingleform "frmStudentsNav", Edit, Normal
Case "cmdStudentsNew"
DoCmd.OpenForm "frmStudentsDataEntry", , , , acFormAdd, acDialog
Case "cmdStudentsEdit"
OpenSingleform "frmStudentContinuous", Edit, Normal
Case "cmdStudentsReports"
OpenSingleform "frmStudentReports", Edit, Normal
'---------------------------------------------------
'---------------------------------------------------
'----------------Teachers---------------------------
Case "cmdTeachers"
OpenSingleform "frmTeachersNav", Edit, Normal
Case "cmdTeachersNew"
DoCmd.OpenForm "frmTeachersDataEntry", , , , acFormAdd, acDialog
Case "cmdTeachersEdit"
OpenSingleform "frmTeacherContinuous", Edit, Normal
Case "cmdTeachersReports"
OpenSingleform "frmTeacherReports", Edit, Normal
'---------------------------------------------------
'---------------------------------------------------
'----------------Courses----------------------------
Case "cmdCourses"
OpenSingleform "frmCoursesNav", Edit, Normal
Case "cmdCoursesNew"
DoCmd.OpenForm "frmCoursesView", , , , acFormAdd
Case "cmdCoursesEdit"
OpenSingleform "frmCoursesContinuous", Edit, Normal
'---------------------------------------------------
'---------------------------------------------------
'----------------Classes----------------------------
Case "cmdClassTimeTable"
OpenSingleform "frmClassTimeTable", Edit, Normal
Case "cmdClassCalendar"
OpenSingleform "frmCalendar", Edit, Normal
Case "cmdClassRegister"
DoCmd.OpenForm "frmDateSelector", , , , , acDialog
DoCmd.OpenReport "rptClassRegister", acViewPreview, , , acWindowNormal
Case "cmdClassLogAttendance"
DoCmd.RunMacro "mcrProgramFlow.LogAttendance"
Case "cmdClassAttendanceReport"
DoCmd.RunMacro "mcrProgramFlow.AttendanceReport"
End Select
End Sub
The Explanation (Brief)
Public Sub onGetLabel(control As IRibbonControl, ByRef label)
'-----------------Other Labels--------------------------------
Select Case control.id
Case "lblDate"
label = FormatDateTime(Date, vbLongDate)
Case "lblUser"
label = getAccessUserName()
Case "lblTerminal"
label = getComputerName()
End Select
End Sub
This sub procedure returns a caption to be used as a label.
Public Sub OnClick(control As IRibbonControl)
Select Case control.id
'---------------------------------------------------
'---------------------------------------------------
'----------------Home---------------------------
Case "cmdHome"
...
End Sub
This code is called when a button or split button (menu item) is clicked. The id of the Ribbon control is passed to the procedure and a select case statement is used to determine what action is performed.
This code needs to be placed in a module called modRibbonDropDownFunctions
Option Compare Database
Option Explicit
Private myArray() As Variant
Sub onGetItemCount(control As IRibbonControl, ByRef count)
count = getTodaysClasses()
End Sub
Public Function getTodaysClasses() As Integer
getTodaysClasses = LoadArray()
End Function
Public Function LoadArray() As Integer
Dim i As Integer
Dim strSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
strSQL = "SELECT tblClass.ClassID, tblClass.ClassDate, " _
& "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[StartTime]) AS StartTime, " _
& "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[EndTime]) AS EndTime, " _
& "Left([tblTeachers].[FirstName],1) & Left([tblTeachers].[LastName],1) AS Teacher, tblLevel.Code " _
& "FROM tblLevel INNER JOIN (tblTeachers INNER JOIN (tblCourse INNER JOIN tblClass " _
& "ON tblCourse.CourseID = tblClass.CourseID) ON tblTeachers.TeacherID = tblClass.TeacherID) " _
& "ON tblLevel.LevelID = tblCourse.Level " _
& "WHERE (((tblClass.ClassDate)=" & CLng(Date) & ")) " _
& "ORDER BY tblClass.ClassDate, DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[StartTime]);"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
With rs
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
ReDim myArray(0 To .RecordCount - 1, 5)
For i = LBound(myArray) To UBound(myArray)
myArray(i, 0) = .Fields("ClassID")
myArray(i, 1) = .Fields("StartTime")
myArray(i, 2) = .Fields("EndTime")
myArray(i, 3) = .Fields("Teacher")
myArray(i, 4) = .Fields("Code")
.MoveNext
Next i
LoadArray = .RecordCount
Else
'Return value = 0
LoadArray = 0
End If
.Close
End With
Set rs = Nothing
Set db = Nothing
End Function
Public Function strGetItemLabel(index As Integer) As String
strGetItemLabel = myArray(index, 1) & " " _
& myArray(index, 2) & " " _
& myArray(index, 3) & " " _
& myArray(index, 4) & " "
End Function
Public Function lngGetItemID(index As Integer) As Long
lngGetItemID = myArray(index, 0)
End Function
Public Sub onGetItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)
returnedVal = strGetItemLabel(index)
End Sub
Public Sub onGetItemID(ctl As IRibbonControl, index As Integer, ByRef id)
id = lngGetItemID(index)
End Sub
Public Sub OnSelectItem(ctl As IRibbonControl, selectedId As String, selectedIndex As Integer)
If (ctl.id = "drpClasses") Then
DoCmd.OpenForm "frmClassView", , , "[ClassID]=" & CLng(selectedId), , acDialog
End If
End Sub
The explanation (brief)
Sub onGetItemCount(control As IRibbonControl, ByRef count)
count = getTodaysClasses()
End Sub
Public Function getTodaysClasses() As Integer
getTodaysClasses = LoadArray()
End Function
Public Function LoadArray() As Integer
Dim i As Integer
Dim strSQL As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
strSQL = "SELECT tblClass.ClassID, tblClass.ClassDate, " _
& "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[StartTime]) AS StartTime, " _
& "DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[EndTime]) AS EndTime, " _
& "Left([tblTeachers].[FirstName],1) & Left([tblTeachers].[LastName],1) AS Teacher, tblLevel.Code " _
& "FROM tblLevel INNER JOIN (tblTeachers INNER JOIN (tblCourse INNER JOIN tblClass " _
& "ON tblCourse.CourseID = tblClass.CourseID) ON tblTeachers.TeacherID = tblClass.TeacherID) " _
& "ON tblLevel.LevelID = tblCourse.Level " _
& "WHERE (((tblClass.ClassDate)=" & CLng(Date) & ")) " _
& "ORDER BY tblClass.ClassDate, DLookUp('[LookUp24Hour]','tblTimes','[LookUpScheduleTime]=' & [tblclass].[StartTime]);"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
With rs
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
ReDim myArray(0 To .RecordCount - 1, 5)
For i = LBound(myArray) To UBound(myArray)
myArray(i, 0) = .Fields("ClassID")
myArray(i, 1) = .Fields("StartTime")
myArray(i, 2) = .Fields("EndTime")
myArray(i, 3) = .Fields("Teacher")
myArray(i, 4) = .Fields("Code")
.MoveNext
Next i
LoadArray = .RecordCount
Else
'Return value = 0
LoadArray = 0
End If
.Close
End With
Set rs = Nothing
Set db = Nothing
End Function
When the Ribbon loads, the initial sub that is called is onGetItemCount as one of the first things the drop down menu needs to know is how many items it will have to hold. Since this is one of the first subs called we can utilise it to load an array of data that we will use to populate the drop down menu.
Public Function strGetItemLabel(index As Integer) As String
strGetItemLabel = myArray(index, 1) & " " _
& myArray(index, 2) & " " _
& myArray(index, 3) & " " _
& myArray(index, 4) & " "
End Function
This sub procedure returns a concatenated string of items from the loaded array. We use the passed index argument to determine which line of the array is being read.
Public Function lngGetItemID(index As Integer) As Long lngGetItemID = myArray(index, 0) End Function
This function looks up a value from the array. The value, in this case, represents the id number of the class being stored. myArray(index, 0) indicates that (if we visualize the array as a table) the row number is whatever is passed as the index value and the column number is 0 (The first element in an array row or column is often 0).
Public Sub OnSelectItem(ctl As IRibbonControl, selectedId As String, selectedIndex As Integer)
If (ctl.id = "drpClasses") Then
DoCmd.OpenForm "frmClassView", , , "[ClassID]=" & CLng(selectedId), , acDialog
End If
End Sub
This sub procedure performs an action based on which drop down menu item is selected.
These are some generic functions that need to be placed in a module called modFunctions. The reason they are apart from the Ribbon code is that other parts of the application may require them and it is important that we know where they are located.
Option Compare Database
Option Explicit
Public Enum DataMode
Add = 1
Edit = 2
End Enum
Public Enum WindowMode
Normal = 1
Dialog = 2
End Enum
Public Function getFirstWeekday(lngFirstDayOfMonth As Long) As Integer
getFirstWeekday = Weekday(lngFirstDayOfMonth, vbMonday)
End Function
Public Function getDaysInMonth(intMonth As Integer, intYear As Integer) As Integer
Dim lngFirstDayOfMonth As Long
Dim lngDatePlusMonth As Long
lngFirstDayOfMonth = DateSerial(intYear, intMonth, 1)
lngDatePlusMonth = DateAdd("m", 1, lngFirstDayOfMonth)
getDaysInMonth = DateDiff("d", lngFirstDayOfMonth, lngDatePlusMonth)
End Function
Public Function getComputerName()
On Error GoTo ErrorHandler
getComputerName = "Terminal: " & Environ$("computername")
Exit_Function:
Exit Function
ErrorHandler:
getComputerName = "Unknown"
Resume Exit_Function
End Function
Public Function getAccessUserName()
On Error GoTo ErrorHandler
getAccessUserName = "User: " & Environ$("username")
Exit_Function:
Exit Function
ErrorHandler:
getAccessUserName = "Unknown"
Resume Exit_Function
End Function
Public Function CloseAllFormsAndReports()
On Error Resume Next
Call CloseAllForms
Call CloseAllReports
On Error GoTo 0
End Function
Public Function CloseAllForms()
On Error Resume Next
Dim frm As Form
Dim i As Integer
For i = Application.Forms.count - 1 To 0 Step -1
DoCmd.Close acForm, Forms(i).Name, acSavePrompt
Next i
On Error GoTo 0
End Function
Public Function CloseAllReports()
On Error Resume Next
Dim rpt As Report
Dim i As Integer
For i = Application.Reports.count - 1 To 0 Step -1
DoCmd.Close acReport, Reports(i).Name, acSavePrompt
Next i
On Error GoTo 0
End Function
Public Sub OpenSingleform(strFormName As String, strDataMode As DataMode, strWindowMode As WindowMode)
On Error Resume Next
Call CloseAllFormsAndReports
If strDataMode = Add And strWindowMode = Normal Then
DoCmd.OpenForm strFormName, , , , acFormAdd, acWindowNormal
ElseIf strDataMode = Edit And strWindowMode = Normal Then
DoCmd.OpenForm strFormName, , , , acFormEdit, acWindowNormal
ElseIf strDataMode = Edit And strWindowMode = Dialog Then
DoCmd.OpenForm strFormName, , , , acFormEdit, acDialog
End If
On Error GoTo 0
End Sub
Related Posts
01 – Introduction to the Ribbon03 – The USysRibbons Table
04 – Tabs, Groups, Buttons and ImageMSOs
05 – Callbacks
06 – Split Buttons
07 – Get Label
08 – Drop Down Menus 1
09 – Drop Down Boxes 2
10 – Splitting a Database
