Search code examples
vbams-accessms-access-2016

Access 2016 Switchboard convert macro to vba


On an Access 2016 Switchboard I converted the macro behind the form to VBA but it wouldn't compile. A band-aid solution I found was to add .Value to TempVars.Add "CurrentItemNumber", ItemNumber and change both instances of Call Argument & "()" to Call Eval(Argument & "()"). This solved the compile error.

I then added another button "Reports Menu" to the Switchboard but when I click on the new button I get this error.

enter image description here

When I click Debug it highlights this line TempVars.Add "SwitchboardID", Argument. When I added .Value to the end of this line TempVars.Add "SwitchboardID", Argument.Value it solved the breakpoint issue and the new button works but now the Report Menu does not fill in properly.

enter image description here

I can click Return To Main to get back to the Main Menu and all other buttons on the Main Menu work fine except the new Reports Menu Button.

Here is the code behind the switchboard...

    Option Compare Database

'------------------------------------------------------------
' Form_Current
'
'------------------------------------------------------------
Private Sub Form_Current()
On Error GoTo Form_Current_Err

  'TempVars.Add "CurrentItemNumber", ItemNumber
  TempVars.Add "CurrentItemNumber", ItemNumber.Value

Form_Current_Exit:
  Exit Sub

Form_Current_Err:
  MsgBox Error$
  Resume Form_Current_Exit

End Sub


'------------------------------------------------------------
' Form_Open
'
'------------------------------------------------------------
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Form_Open_Err

  TempVars.Add "SwitchboardID", DLookup("SwitchboardID", "Switchboard Items", "[ItemNumber] = 0 AND [Argument] = 'Default'")
  DoCmd.SetProperty "Label1", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
  DoCmd.SetProperty "Label2", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
  DoCmd.Requery ""


Form_Open_Exit:
  Exit Sub

Form_Open_Err:
  MsgBox Error$
  Resume Form_Open_Exit

End Sub


'------------------------------------------------------------
' Option1_Click
'
'------------------------------------------------------------
Private Sub Option1_Click()
On Error GoTo Option1_Click_Err

  On Error GoTo 0
  If (Command = 1) Then
    'TempVars.Add "SwitchboardID", Argument
    TempVars.Add "SwitchboardID", Argument.Value
    DoCmd.SetProperty "Label1", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.SetProperty "Label2", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.Requery ""
    Exit Sub
  End If
  If (Command = 2) Then
    DoCmd.OpenForm Argument, acNormal, "", "", acAdd, acNormal
    Exit Sub
  End If
  If (Command = 3) Then
    DoCmd.OpenForm Argument, acNormal, "", "", , acNormal
    Exit Sub
  End If
  If (Command = 4) Then
    DoCmd.OpenReport Argument, acViewReport, "", "", acNormal
    Exit Sub
  End If
  If (Command = 5) Then
    DoCmd.RunCommand acCmdSwitchboardManager
    TempVars.Add "SwitchboardID", DLookup("SwitchboardID", "Switchboard Items", "[ItemNumber] = 0 AND [Argument] = 'Default'")
    DoCmd.SetProperty "Label1", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.SetProperty "Label2", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.Requery ""
    Exit Sub
  End If
  If (Command = 6) Then
    DoCmd.CloseDatabase
    Exit Sub
  End If
  If (Command = 7) Then
    DoCmd.RunMacro Argument, , ""
    Exit Sub
  End If
  If (Command = 8) Then
    'Call Argument & "()"
    Call Eval(Argument & "()")
    Exit Sub
  End If
  Beep
  MsgBox "Unknown option.", vbOKOnly, ""


Option1_Click_Exit:
  Exit Sub

Option1_Click_Err:
  MsgBox Error$
  Resume Option1_Click_Exit

End Sub


'------------------------------------------------------------
' OptionLabel1_Click
'
'------------------------------------------------------------
Private Sub OptionLabel1_Click()
On Error GoTo OptionLabel1_Click_Err

  On Error GoTo 0
  If (Command = 1) Then
    'TempVars.Add "SwitchboardID", Argument
    TempVars.Add "SwitchboardID", Argument.Value
    DoCmd.SetProperty "Label1", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.SetProperty "Label2", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.Requery ""
    Exit Sub
  End If
  If (Command = 2) Then
    DoCmd.OpenForm Argument, acNormal, "", "", acAdd, acNormal
    Exit Sub
  End If
  If (Command = 3) Then
    DoCmd.OpenForm Argument, acNormal, "", "", , acNormal
    Exit Sub
  End If
  If (Command = 4) Then
    DoCmd.OpenReport Argument, acViewReport, "", "", acNormal
    Exit Sub
  End If
  If (Command = 5) Then
    DoCmd.RunCommand acCmdSwitchboardManager
    TempVars.Add "SwitchboardID", DLookup("SwitchboardID", "Switchboard Items", "[ItemNumber] = 0 AND [Argument] = 'Default'")
    DoCmd.SetProperty "Label1", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.SetProperty "Label2", acPropertyCaption, DLookup("ItemText", "Switchboard Items", "[SwitchboardID] = " & TempVars("SwitchboardID"))
    DoCmd.Requery ""
    Exit Sub
  End If
  If (Command = 6) Then
    DoCmd.CloseDatabase
    Exit Sub
  End If
  If (Command = 7) Then
    DoCmd.RunMacro Argument, , ""
    Exit Sub
  End If
  If (Command = 8) Then
    'Call Argument & "()"
    Call Eval(Argument & "()")
    Exit Sub
  End If
  Beep
  MsgBox "Unknown option.", vbOKOnly, ""


OptionLabel1_Click_Exit:
  Exit Sub

OptionLabel1_Click_Err:
  MsgBox Error$
  Resume OptionLabel1_Click_Exit

End Sub

Any suggestions would be appreciated..

Thanks in advance.


Solution

  • I really appreciate the responses but due to time constrains I threw in the towel trying to fix this code that was generated by Access 2016 (when it converted the macros) and grabbed Switchboard from code from an older database that works. I believe that code was created with Access 2003 but it still works perfectly (see below) It has a limit of 8 buttons per switchboard but it should be enough for most applications.

    Option Compare Database
    
    Private Sub Form_Open(Cancel As Integer)
    ' Minimize the database window and initialize the form.
    
    ' Move to the switchboard page that is marked as the default.
    Me.Filter = "[ItemNumber] = 0 AND [Argument] = 'Default' "
    Me.FilterOn = True
    
    End Sub
    
    Private Sub Form_Current()
    ' Update the caption and fill in the list of options.
    
    Me.Caption = Nz(Me![ItemText], "")
    FillOptions
    
    End Sub
    
    Private Sub FillOptions()
    ' Fill in the options for this switchboard page.
    
    ' The number of buttons on the form.
    Const conNumButtons = 8
    
    Dim con As Object
    Dim RS As Object
    Dim stSql As String
    Dim intOption As Integer
    
    ' Set the focus to the first button on the form,
    ' and then hide all of the buttons on the form
    ' but the first.  You can't hide the field with the focus.
    Me![Option1].SetFocus
    For intOption = 2 To conNumButtons
        Me("Option" & intOption).Visible = False
        Me("OptionLabel" & intOption).Visible = False
    Next intOption
    
    ' Open the table of Switchboard Items, and find
    ' the first item for this Switchboard Page.
    Set con = Application.CurrentProject.Connection
    stSql = "SELECT * FROM [Switchboard Items]"
    stSql = stSql & " WHERE [ItemNumber] > 0 AND [SwitchboardID]=" & Me![SwitchboardID]
    stSql = stSql & " ORDER BY [ItemNumber];"
    Set RS = CreateObject("ADODB.Recordset")
    RS.Open stSql, con, 1   ' 1 = adOpenKeyset
    
    ' If there are no options for this Switchboard Page,
    ' display a message.  Otherwise, fill the page with the items.
    If (RS.EOF) Then
        Me![OptionLabel1].Caption = "There are no items for this switchboard page"
    Else
        While (Not (RS.EOF))
            Me("Option" & RS![ItemNumber]).Visible = True
            Me("OptionLabel" & RS![ItemNumber]).Visible = True
            Me("OptionLabel" & RS![ItemNumber]).Caption = RS![ItemText]
            RS.MoveNext
        Wend
    End If
    
    ' Close the recordset and the database.
    RS.Close
    Set RS = Nothing
    Set con = Nothing
    
    End Sub
    
    Private Function HandleButtonClick(intBtn As Integer)
    ' This function is called when a button is clicked.
    ' intBtn indicates which button was clicked.
    
    ' Constants for the commands that can be executed.
    Const conCmdGotoSwitchboard = 1
    Const conCmdOpenFormAdd = 2
    Const conCmdOpenFormBrowse = 3
    Const conCmdOpenReport = 4
    Const conCmdCustomizeSwitchboard = 5
    Const conCmdExitApplication = 6
    Const conCmdRunMacro = 7
    Const conCmdRunCode = 8
    Const conCmdOpenPage = 9
    
    ' An error that is special cased.
    Const conErrDoCmdCancelled = 2501
    
    Dim con As Object
    Dim RS As Object
    Dim stSql As String
    
    On Error GoTo HandleButtonClick_Err
    
    ' Find the item in the Switchboard Items table
    ' that corresponds to the button that was clicked.
    Set con = Application.CurrentProject.Connection
    Set RS = CreateObject("ADODB.Recordset")
    stSql = "SELECT * FROM [Switchboard Items] "
    stSql = stSql & "WHERE [SwitchboardID]=" & Me![SwitchboardID] & " AND [ItemNumber]=" & intBtn
    RS.Open stSql, con, 1    ' 1 = adOpenKeyset
    
    ' If no item matches, report the error and exit the function.
    If (RS.EOF) Then
        MsgBox "There was an error reading the Switchboard Items table."
        RS.Close
        Set RS = Nothing
        Set con = Nothing
        Exit Function
    End If
    
    Select Case RS![Command]
    
        ' Go to another switchboard.
        Case conCmdGotoSwitchboard
            Me.Filter = "[ItemNumber] = 0 AND [SwitchboardID]=" & RS![Argument]
    
        ' Open a form in Add mode.
        Case conCmdOpenFormAdd
            DoCmd.OpenForm RS![Argument], , , , acAdd
    
        ' Open a form.
        Case conCmdOpenFormBrowse
            DoCmd.OpenForm RS![Argument]
    
        ' Open a report.
        Case conCmdOpenReport
            DoCmd.OpenReport RS![Argument], acPreview
    
        ' Customize the Switchboard.
        Case conCmdCustomizeSwitchboard
            ' Handle the case where the Switchboard Manager
            ' is not installed (e.g. Minimal Install).
            On Error Resume Next
            Application.Run "ACWZMAIN.sbm_Entry"
            If (Err <> 0) Then MsgBox "Command not available."
            On Error GoTo 0
            ' Update the form.
            Me.Filter = "[ItemNumber] = 0 AND [Argument] = 'Default' "
            Me.Caption = Nz(Me![ItemText], "")
            FillOptions
    
        ' Exit the application.
        Case conCmdExitApplication
            CloseCurrentDatabase
    
        ' Run a macro.
        Case conCmdRunMacro
            DoCmd.RunMacro RS![Argument]
    
        ' Run code.
        Case conCmdRunCode
            Application.Run RS![Argument]
    
        ' Open a Data Access Page
        Case conCmdOpenPage
            DoCmd.OpenDataAccessPage RS![Argument]
    
        ' Any other command is unrecognized.
        Case Else
            MsgBox "Unknown option."
    
    End Select
    
    ' Close the recordset and the database.
    RS.Close
    
    HandleButtonClick_Exit:
    On Error Resume Next
    Set RS = Nothing
    Set con = Nothing
    Exit Function
    
    HandleButtonClick_Err:
    ' If the action was cancelled by the user for
    ' some reason, don't display an error message.
    ' Instead, resume on the next line.
    If (Err = conErrDoCmdCancelled) Then
        Resume Next
    Else
        MsgBox "There was an error executing the command.", vbCritical
        Resume HandleButtonClick_Exit
    End If
    
    End Function
    

    Hope this can help someone else...