[求助]提示：参数类型不正确，或不在可以接受的范围之内，或与其他参数冲突。

sunwrsun

[求助]前台A床cess，后台SQL。登录提示：参数类型不正确，或不在可以接受的范围之内，或与其他参数冲突。

'创建系统菜单栏

Public Sub CreateMenuBar()

On Error GoToErr_CreateMenuBar

    Const strMenubarName   As String ="CustomSystemMenu"  '自定义系统菜单栏名称

    Dim rst As New ADODB.Recordset

    Dim bar As Object

    Dim bar2 As Object

    Dim ctl As Object

    Dim rst2 As New ADODB.Recordset

    Dim strSql As String

    Dim strSQL2 As String

    Dim blnHide As Boolean

    '循环所有菜单栏，如果定义名称的菜单栏存在，则将其删除

    For Each bar In Application.CommandBars

        If bar.Name = strMenubarName ThenCommandBars(strMenubarName).Delete

    Next

    '重新创建菜单栏

    Set bar = CommandBars.Add(strMenubarName,1, True, True)    'msoBarTop=1

    bar.Protection = 4    'msoBarNoMove 禁止移动菜单栏

    '读取设置决定是否显示无权访问的菜单及菜单项

    blnHide =GetDbSetting("HideMenuForNoRight", False)

    strSql = " SELECTFUserId,USysMenuItems.FItemId, FItemText, FShortcutKey,FParent,FOpenRun,FAdd,FEdit,FDelete,FPrint,FOutput" & _

             " FROM USysUserRights RIGHTJOIN USysMenuItems ON USysUserRights.FItemId = USysMenuItems.FItemId"& _

             " WHERE FParent=0 AndFUserId=" & Forms!frmLogon!txtUserId

    If blnHide Then strSql = strSql &" AND FOpenRun=True"

    strSql = strSql & " ORDER BYFOrder"

'    Debug.Print strSQL2

    strSQL2 = " SELECTT.FOrder,T.FItemId,T.FItemText,T.FCommand,T.FArgument,T.FShortcutKey,T.FParent,"& _

                     "R.FOpenRun,R.FAdd,R.FEdit,R.FDelete,R.FPrint,R.FOutput" &_

             " FROM (USysUserRightsAS R RIGHT JOIN USysMenuItems AST ON R.FItemId = T.FItemId)" & _

             " WHERE R.FUserId="& Forms!frmLogon!txtUserId

    If blnHide Then strSQL2 = strSQL2 &" AND R.FOpenRun=True"

    strSQL2 = strSQL2 & " ORDER BYT.FOrder"

'    Debug.Print strSQL2

    rst.Open strSql, CurrentProject.Connection,adOpenKeyset, adLockReadOnly

    rst2.Open strSQL2,CurrentProject.Connection, adOpenKeyset, adLockReadOnly

    Do Until rst.EOF

        Set bar =CommandBars(strMenubarName).Controls.Add(10)   'msoControlPopup=10

        bar.Caption = rst!FItemText &rst!FShortcutKey

        If Not blnHide Then bar.Enabled =rst!FOpenRun

        rst2.Filter = "FParent="& rst!FItemId

        Do Until rst2.EOF

            Set ctl =bar.CommandBar.Controls.Add(1) 'msoControlButton

            ctl.Caption = Nz(rst2!FItemText) &Nz(rst2!FShortcutKey)

            If Not blnHide Then ctl.Enabled =rst!FOpenRun And rst2!FOpenRun

            If ctl.Enabled Then ctl.OnAction ="=RunMenuCommand('" & Nz(rst2!FCommand) & "','"& Nz(rst2!FArgument) & "'," & _

                                               (rst!FOpenRun And rst2!FOpenRun) & "," & (rst!FAdd Andrst2!FAdd) & "," & _

                                               (rst!FEdit And rst2!FEdit) & "," & (rst!FDelete Andrst2!FDelete) & "," & _

                                                (rst!FPrintAnd rst2!FPrint) & "," & (rst!FOutput And rst2!FOutput) &")"

            rst2.MoveNext

        Loop

        rst.MoveNext

    Loop

    rst.Close

    rst2.Close

    CommandBars(strMenubarName).Visible = True

Exit_CreateMenuBar:

    Exit Sub

Err_CreateMenuBar:

    Msgbox "ModRight Sub_CreateMenuBar" & vbCr &Err.Description, vbCritical

    Resume Exit_CreateMenuBar

End Sub

roych

别的没留意到，然而部分语句似乎少了空格：
If bar.Name = strMenubarName ThenCommandBars(strMenubarName).Delete
应为：
If bar.Name = strMenubarName Then CommandBars(strMenubarName).Delete
SQL语句错得太多，懒得说了。select、where 、and、order by……自己检查吧。

sunwrsun

十分感谢roych帮助，我试试看。

sunwrsun

我检查了一下如roych所说源代码的部分语句似本来是有空格的，我是先复制到Word后再复制到论坛上，就出现了部分语句少了空格。所以未在意。我现在直接复制上来，麻烦roych再看看，谢谢。

'创建系统菜单栏
Public Sub CreateMenuBar()
On Error GoTo Err_CreateMenuBar
    Const strMenubarName   As String = "CustomSystemMenu"  '自定义系统菜单栏名称

    Dim rst As New ADODB.Recordset
    Dim bar As Object
    Dim bar2 As Object
    Dim ctl As Object

    Dim rst2 As New ADODB.Recordset
    Dim strSql As String
    Dim strSQL2 As String
    Dim blnHide As Boolean

    '循环所有菜单栏，如果定义名称的菜单栏存在，则将其删除
    For Each bar In Application.CommandBars
        If bar.Name = strMenubarName Then CommandBars(strMenubarName).Delete
    Next
    '重新创建菜单栏
    Set bar = CommandBars.Add(strMenubarName, 1, True, True)    'msoBarTop=1
    bar.Protection = 4    'msoBarNoMove 禁止移动菜单栏

    '读取设置决定是否显示无权访问的菜单及菜单项
    blnHide = GetDbSetting("HideMenuForNoRight", False)

    strSql = " SELECT FUserId,USysMenuItems.FItemId, FItemText, FShortcutKey, FParent,FOpenRun,FAdd,FEdit,FDelete,FPrint,FOutput" & _
             " FROM USysUserRights RIGHT JOIN USysMenuItems ON USysUserRights.FItemId = USysMenuItems.FItemId" & _
             " WHERE FParent=0 And FUserId=" & Forms!frmLogon!txtUserId
    If blnHide Then strSql = strSql & " AND FOpenRun=True"
    strSql = strSql & " ORDER BY FOrder"
'    Debug.Print strSQL2
    strSQL2 = " SELECT T.FOrder,T.FItemId,T.FItemText,T.FCommand,T.FArgument,T.FShortcutKey,T.FParent," & _
                      "R.FOpenRun,R.FAdd,R.FEdit,R.FDelete,R.FPrint,R.FOutput" & _
             " FROM (USysUserRights AS R RIGHT JOIN USysMenuItems AS T ON R.FItemId = T.FItemId)" & _
             " WHERE R.FUserId=" & Forms!frmLogon!txtUserId
    If blnHide Then strSQL2 = strSQL2 & " AND R.FOpenRun=True"
    strSQL2 = strSQL2 & " ORDER BY T.FOrder"
'    Debug.Print strSQL2
    rst.Open strSql, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
    rst2.Open strSQL2, CurrentProject.Connection, adOpenKeyset, adLockReadOnly

    Do Until rst.EOF
        Set bar = CommandBars(strMenubarName).Controls.Add(10)    'msoControlPopup=10
        bar.Caption = rst!FItemText & rst!FShortcutKey
        If Not blnHide Then bar.Enabled = rst!FOpenRun
        rst2.Filter = "FParent=" & rst!FItemId
        Do Until rst2.EOF
            Set ctl = bar.CommandBar.Controls.Add(1) 'msoControlButton
            ctl.Caption = Nz(rst2!FItemText) & Nz(rst2!FShortcutKey)
            If Not blnHide Then ctl.Enabled = rst!FOpenRun And rst2!FOpenRun
            If ctl.Enabled Then ctl.OnAction = "=RunMenuCommand('" & Nz(rst2!FCommand) & "','" & Nz(rst2!FArgument) & "'," & _
                                                (rst!FOpenRun And rst2!FOpenRun) & "," & (rst!FAdd And rst2!FAdd) & "," & _
                                                (rst!FEdit And rst2!FEdit) & "," & (rst!FDelete And rst2!FDelete) & "," & _
                                                (rst!FPrint And rst2!FPrint) & "," & (rst!FOutput And rst2!FOutput) & ")"
            rst2.MoveNext
        Loop
        rst.MoveNext
    Loop

    rst.Close
    rst2.Close

    CommandBars(strMenubarName).Visible = True

Exit_CreateMenuBar:
    Exit Sub

Err_CreateMenuBar:
    Msgbox "ModRight Sub_CreateMenuBar" & vbCr & Err.Description, vbCritical
    Resume Exit_CreateMenuBar

End Sub