You need to use the Ribbon for top level menus:
See my article on Ribbons to get started:
http://www.rptsoftware.com/help/microsoft_access_general/ribbon1.asp
and this site:
http://www.accessribbon.de/en/
for popup menus I found that code still works. Here's a ton of code I use
for one application:
You need a reference to the Microsoft Office library
HTH,
Mark
RPT Software
http://www.rptsoftware.com
Public Function CreatePopupMenu()
On Error GoTo Err_CreatePopupMenu
'Creates the popup menus that are used when right-clicking on
'an event in the calendar
Dim MenuName As String
Dim CBS As Office.CommandBars
Dim CB As CommandBar
Dim CBC As CommandBarControl
Dim CBB As CommandBarButton
Dim CBP As CommandBarPopup
Dim db As Database
Dim rs As DAO.Recordset
Dim sql As String
'****Create first menu (used when on right clicking ON an event)
MenuName = "RPTPopupOnEvent"
'delete menu if it already exists
If fIsCreated(MenuName) Then
Application.CommandBars(MenuName).Delete
End If
'create menu and appropriate commandbuttons
Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False,
False)
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Cut"
CBB.Tag = "Cut"
CBB.FaceId = 21
CBB.OnAction = "=CutEvent()"
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Copy"
CBB.Tag = "Copy"
CBB.FaceId = 19
CBB.OnAction = "=CopyEvent()"
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Delete"
CBB.Tag = "Delete"
CBB.FaceId = 358
CBB.OnAction = "=CutEvent()"
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Edit"
CBB.Tag = "Edit"
CBB.FaceId = 162
CBB.OnAction = "=EditEvent()"
Set CBP = CB.Controls.Add(msoControlPopup, , , , True)
CBP.Caption = "Status"
CBP.Tag = "Status"
sql = "SELECT EventStatus from tblEventStatus"
Set db = CurrentDb()
Set rs = db.OpenRecordset(sql, dbOpenDynaset)
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do While Not rs.EOF
Set CBB = CBP.Controls.Add(msoControlButton, , , , True)
CBB.Caption = rs("EventStatus")
CBB.Tag = rs("EventStatus")
CBB.FaceId = 1
CBB.OnAction = "=AdjustPopupMenu(""" & rs("EventStatus") & """)"
rs.MoveNext
Loop
End If
rs.Close
'****Create second menu (used when on right clicking NOT ON an event)
MenuName = "RPTPopupOffEvent"
'delete menu if it already exists
If fIsCreated(MenuName) Then
Application.CommandBars(MenuName).Delete
End If
'create menu and appropriate commandbuttons
Set CB = Application.CommandBars.Add(MenuName, msoBarPopup, False,
False)
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Paste"
CBB.Tag = "Paste"
CBB.FaceId = 22
CBB.OnAction = "=PasteEvent()"
Set CBB = CB.Controls.Add(msoControlButton, , , , True)
CBB.Caption = "Add..."
CBB.Tag = "Add..."
CBB.FaceId = 530
CBB.OnAction = "=AddEvent()"
Exit_CreatePopupMenu:
Set rs = Nothing
Set db = Nothing
Exit Function
Err_CreatePopupMenu:
MsgBox Err.Description
Resume Exit_CreatePopupMenu
End Function
Public Function AdjustPopupMenu(txtStatus As String)
'Adjusts which status values shows a check mark (only one can be checked)
Dim CBS As Office.CommandBars
Dim CB As CommandBar
Dim CBC As CommandBarControl
Dim CBB As CommandBarButton
Dim sql As String
Set CBS = Application.CommandBars
Set CB = CBS("RPTPopupOnEvent")
Set CBC = CB.Controls("Status")
For Each CBB In CBC.Controls
If (CBB.Caption = txtStatus) Then
CBB.State = msoButtonDown
Else
CBB.State = msoButtonUp
End If
Next
Set CBB = Nothing
Set CBC = Nothing
Set CB = Nothing
Set CBS = Nothing
End Function
Public Function AdjustStatusAfterPopupIfNeeded(EventID As String)
'Adjusts the collection if the user changed the status value using a popup
menu
Dim CBS As Office.CommandBars
Dim CB As CommandBar
Dim CBC As CommandBarControl
Dim CBB As CommandBarButton
Dim sql As String
Dim oldStatus As String
Dim newStatus As String
oldStatus = m_oEvents.Item(EventID).AppointmentStatus
newStatus = oldStatus
Set CBS = Application.CommandBars
Set CB = CBS("RPTPopupOnEvent")
Set CBC = CB.Controls("Status")
For Each CBB In CBC.Controls
If (CBB.State = msoButtonDown) Then
newStatus = CBB.Caption
End If
Next
Set CBB = Nothing
Set CBC = Nothing
Set CB = Nothing
Set CBS = Nothing
If (newStatus <> oldStatus) Then
m_oEvents.Item(EventID).AppointmentStatus = newStatus
m_oEvents.Item(EventID).RecordStatus = "SAVE"
End If
End Function
Public Function CreateTestBar()
Dim I As Integer
Dim x As Integer
Dim y As Integer
'i the popmenus
'x is the buttons
x = 1
I = 1
y = 1
strMenuName = "PopUpTest40833" 'Make sure you don't have a button named
"ButtonTest40833", this function would delete it.
If fIsCreated(strMenuName) Then
Application.CommandBars(strMenuName).Delete
End If
Set cmdNewMenu = Application.CommandBars.Add(strMenuName, msoBarPopup,
False, False)
For I = 1 To 100
Set cctlSubMenu = cmdNewMenu.Controls.Add(Type:=10)
With cctlSubMenu
.Caption = I
.BeginGroup = True
End With
y = x + 50
For x = x To (y)
Set CBarCtl =
cctlSubMenu.Controls.Add(Type:=msoControlButton)
With CBarCtl
.Caption = Chr(34) & x & Chr(34)
.FaceId = x
End With
Next
Next
cmdNewMenu.Visible = True
End Function
Function fIsCreated(strMenuName) As Boolean
Dim intNumberMenus As Integer
Dim I As Integer
intNumberMenus = Application.CommandBars.count
fIsCreated = False
For I = 1 To intNumberMenus
If Application.CommandBars(I).Name = strMenuName Then
fIsCreated = True
I = intNumberMenus
End If
Next
End Function
