Creating a CommandBar 1

[bartus991]

For a new database (accdb) in access 2010 im busy creating a new submenu. In the past with access 2003 it was a bit easier and I can't figure out how to solve this.

What is it what i want to create.
It is a copy button, you select a day, lets say Thursday. If you push the button it gives you the following shortcutmenu:

Copy from day
   --> Monday
   --> Tuesday
   --> Wednesday
   --> Thursday (must be grey/inactive as this is the selected day
   --> Friday
   --> Saturday
   --> Sunday
Copy to day
   --> Monday
   --> Tuesday
   etc..

Click the day will fire off an VBA programmed query or something like that.
I used an old copy of Access 2003 to try to create this in access 2010, but it cant find the cbProducts Commandbar and I can't add it, it also gives me the error: Office.CommandBarControl is not defined.
The code i uses

Option Compare Database
Option Explicit

Public Sub createProductCommandBar()
  Const conBarName = "cbProducts"
  
  Dim rsCat As dao.Recordset
  Dim rsProducts As dao.Recordset
  Dim rsOrders As dao.Recordset
  Dim strSql As String
  Dim catCaption As String
  Dim catValue As Long
  Dim prodCaption As String
  Dim prodValue As Long
  Dim cbCat As Office.CommandBar
  Dim cbCatCtrl As Office.CommandBarControl
  Dim cbProdCtl As Office.CommandBarControl
  Dim ctl As CommandBarControl
  Dim cb As CommandBar
  
  
  Set rsCat = CurrentDb.OpenRecordset("qryCategories", dbReadOnly)
  If isCommandBar(conBarName) Then
    Application.CommandBars(conBarName).Delete
  End If
  Set cbCat = CommandBars.Add(conBarName, msoBarPopup, False, True)
  
  Do While Not rsCat.EOF
    catCaption = rsCat!CategoryName
    catValue = rsCat!CategoryID
    strSql = "Select * from qryProducts where CategoryID = " & catValue
    Set cbCatCtrl = cbCat.Controls.Add(msoControlPopup)
    cbCatCtrl.Caption = catCaption
    
    Set rsProducts = CurrentDb.OpenRecordset(strSql, dbReadOnly)
    Do While Not rsProducts.EOF
      Set cbProdCtl = cbCatCtrl.Controls.Add()
      prodCaption = rsProducts!ProductName
      prodValue = rsProducts!productID
      cbProdCtl.Caption = prodCaption
      cbProdCtl.Tag = prodValue
      cbProdCtl.OnAction = "subFilterOrders"
      rsProducts.MoveNext
    Loop
    rsCat.MoveNext
  Loop
End Sub

Public Sub subFilterOrders()
  Dim cbCtl As CommandBarControl
  Dim strSql As String
  Set cbCtl = CommandBars.ActionControl
  strSql = "Select * from qryOrders where ProductID = " & CInt(cbCtl.Tag)
  Forms("frmDemo").subOrders.Form.RecordSource = strSql
End Sub

Public Function isCommandBar(strBarName As String) As Boolean
  Dim cb As CommandBar
  For Each cb In Application.CommandBars
    If cb.Name = strBarName Then
      isCommandBar = True
    End If
  Next cb
End Function

Public Sub createEmployeeCommandBar()
  Const conBarName = "cbEmployees"
  
  Dim rsEmp As dao.Recordset
  Dim strSql As String
  Dim empCaption As String
  Dim empValue As Long
  Dim cbEmp As Office.CommandBar
  Dim cbEmpCtrl As Office.CommandBarControl
  Dim ctl As CommandBarControl
  Dim cb As CommandBar
  
  
  Set rsEmp = CurrentDb.OpenRecordset("qryEmployees", dbReadOnly)
  If isCommandBar(conBarName) Then
    Application.CommandBars(conBarName).Delete
  End If
  Set cbEmp = CommandBars.Add(conBarName, msoBarPopup, False, True)
  
  Do While Not rsEmp.EOF
    empCaption = rsEmp!EmployeeName
    empValue = rsEmp!EmployeeID
    Set cbEmpCtrl = cbEmp.Controls.Add(msoControlButton, , empValue)
    cbEmpCtrl.Tag = empValue
    cbEmpCtrl.Caption = empCaption
    cbEmpCtrl.OnAction = "SelectEmployee"
    rsEmp.MoveNext
  Loop
End Sub

Public Sub createSupplierCommandBar()
  Const conBarName = "cbSuppliers"
  
  Dim rsSup As dao.Recordset
  Dim strSql As String
  Dim SupCaption As String
  Dim SupValue As Long
  Dim cbSup As Office.CommandBar
  Dim cbSupCtrl As Office.CommandBarControl
  Dim ctl As CommandBarControl
  Dim cb As CommandBar
  
  
  Set rsSup = CurrentDb.OpenRecordset("qrySuppliers", dbReadOnly)
  If isCommandBar(conBarName) Then
    Application.CommandBars(conBarName).Delete
  End If
  Set cbSup = CommandBars.Add(conBarName, msoBarPopup, False, True)
  
  Do While Not rsSup.EOF
    SupCaption = rsSup!CompanyName
    SupValue = rsSup!SupplierID
    Set cbSupCtrl = cbSup.Controls.Add(msoControlButton, , SupValue)
    cbSupCtrl.Tag = SupValue
    cbSupCtrl.Caption = SupCaption
    cbSupCtrl.OnAction = "SelectSupplier"
    rsSup.MoveNext
  Loop
End Sub

Public Sub selectEmployee()
  Forms("frmDemo").txtCmdBar = DLookup("EmployeeName", "qryEmployees", "EmployeeID = " & CommandBars.ActionControl.Tag)
End Sub

Public Sub selectSupplier()
  Forms("frmDemo").txtCmdBar = DLookup("CompanyName", "qrySuppliers", "SupplierID = " & CommandBars.ActionControl.Tag)
End Sub

Any help suggestions would be appreciated as I'm stuck. Already tried to import the old database including toolbars, but with out success.

 

[MajP]

I recognize that code as mine. Here is a link to the working demo

http://www.4shared.com/office/T7xNNRcj/MajPShortCutMenuControlBar_V3.html

As the original thread showed you need to have a reference to "Microsoft Office 14.0 Objects

 

[bartus991]

Many many thanx MajP! The problem was the reference of the Microsoft Office 14.0 Objects. You code is really terrific, used it several times in older databases and it works perfect, easy to change. The original database was lost, so thanx for uploading it again!

 

[MajP]

The original idea was posed by someone else in thread702-1588743. I had never seen the concept done before in vba, but after doing it found out it worked really well. In VB.net you can add a control like that very easily, it would be nice to have something like that in vba. It would make cascading combos a lot cleaner.

 

[Andrzejek]

MajP, you stated: "In VB.net you can add a control like that very easily"

I asked this question here: thread796-1700350 , but no answer so far. :-(


Have fun.

---- Andy

 

[MajP]

I would think you get the same effect by simply creating a context menu strip. Maybe I do not understand what effect you are looking for.