Custom Command Bar Control Fires Twice

[123FakeSt]

This is the relevant part of my code that creates the button and action:

        Set oVal = oOpt.Controls.Add(Type:=msoControlButton)
        oVal.Visible = True
        oVal.Caption = oRS.Fields("schName").Value
        oVal.OnAction = "LoadReport(""" & oRS.Fields("schName").Value & """)"

Which calls this function:

Public Function LoadReport(strReport As String)
MsgBox "Will load " & strReport
End Function

For some reason it happens twice when I test it. This is the entire code:

Private Function BuildMenu()

'Variables needed for ADODB. Must have reference to Microsoft ActiveX Data Objects 2.8
Dim oConn As ADODB.Connection
Dim oRS As ADODB.Recordset
Dim strConn As String
Dim strSQL As String
Dim strCurGroup As String
'Variables needed for Windows toolbar objects
Dim oBar As CommandBar
Dim oMenu As CommandBarControl
Dim oOpt As CommandBarControl
Dim oVal As CommandBarControl
Dim iHelp As Integer

'Open report list as recordset
strConn = "Provider=sqloledb;Data Source=ABC;Initial Catalog=report;Integrated Security=SSPI;"
strSQL = "SELECT schUserGroup,schName FROM tblScheduledReport WHERE schIsActive = 1 " & _
    "ORDER BY schUserGroup, schName"
Set oConn = New ADODB.Connection
oConn.Open strConn
Set oRS = New ADODB.Recordset
oRS.Open strSQL, oConn, adOpenForwardOnly, adLockReadOnly

'Build the HAP XL drop down menu
Set oBar = Application.CommandBars("Worksheet Menu Bar")
For Each oMenu In oBar.Controls
    If oMenu.Caption = "&HAPXL" Then oBar.Controls("HAPXL").Delete
Next
iHelp = oBar.Controls("Help").Index
Set oMenu = oBar.Controls.Add(msoControlPopup, , , iHelp)
oMenu.Caption = "&HAPXL"
oMenu.Visible = True

'Run through recordset adding groups and then reports for that group
If Not oRS.EOF Then
    oRS.MoveFirst
    Do Until oRS.EOF
        If oRS.Fields("schUserGroup").Value <> strCurGroup Then
            strCurGroup = oRS.Fields("schUserGroup").Value
            Set oOpt = oMenu.Controls.Add(Type:=msoControlPopup)
            oOpt.Visible = True
            oOpt.Caption = strCurGroup
        End If
        Set oVal = oOpt.Controls.Add(Type:=msoControlButton)
        oVal.Visible = True
        oVal.Caption = oRS.Fields("schName").Value
        oVal.OnAction = "LoadReport(""" & oRS.Fields("schName").Value & """)"
        Set oVal = Nothing
        oRS.MoveNext
    Loop
    Set oOpt = Nothing
End If

ProcExit:
    Set oConn = Nothing
    Set oRS = Nothing
    Set xlWS = Nothing
    Exit Function
ProcErr:
    MsgBox "Unable to connect to the report list", vbCritical
    Resume ProcExit
End Function

Public Function LoadReport(strReport As String)
MsgBox "Will load " & strReport
End Function

The early bird gets the worm, but the second mouse gets the cheese.

 

[combo]

Looks like OnAction fails when one try to pass an argument to a procedure this way.
Another apporoach:

1. create custom class (name: clsCommandBarButton) with:

Public WithEvents cbButton As Office.CommandBarButton
Public strReport As String

Private Sub cbButton_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
MsgBox "Will load " & strReport
End Sub

Private Sub Class_Terminate()
Set cbButton = Nothing
End Sub

2. in a standard module with your function:

' declare two variables, public as collection and any as clsCommandBarButton type:
Dim colButtons As Collection
Dim cCustomButton As clsCommandBarButton

' in the function, outside loop, instantiate collection:
Set colButtons = New Collection

' in the loop, together with creation of new buttons:
Set cCustomButton = New clsCommandBarButton
With cCustomButton
    Set .cbButton = oVal
    .strReport = oRS.Fields("schName").Value
End With
colButtons.Add cCustomButton

combo