access 自主菜单.txt

来自「用Access做程序,需要自己的菜单,在数据库中建一个菜单表和权限表,即可方便实」· 文本 代码 · 共 62 行

Public Sub AddSelfMenu()
    Dim Ctrl As CommandBarPopup
    Dim rsT As ADODB.Recordset
    Set rsT = New ADODB.Recordset
    Dim rst2 As ADODB.Recordset
    Set rst2 = New ADODB.Recordset
    Dim MenuCaption As String
    Dim NewMenu As CommandBarPopup
    Dim SubMenu As Variant
    Dim strSQL, strSQL2, Book As String
    On Error Resume Next
    
    ResumeSysMenu False
    
    strSQL = "SELECT * FROM dbo.Menu INNER JOIN dbo.MenuPower ON dbo.Menu.Menue_ID = dbo.MenuPower.MenueID " & _
             "WHERE (dbo.MenuPower.UsrID = N'" & UsrID & "') AND (dbo.MenuPower.PowerUSR = 1) AND (Parant_ID like 'Top');"

    rsT.Open strSQL, cnn, adOpenDynamic, adLockReadOnly, adCmdText

    Do Until rsT.EOF
        
        MenuCaption = rsT(2)
        
        Set NewMenu = CommandBars.ActiveMenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
        With NewMenu
            .Caption = MenuCaption
            .Tag = rsT(0)
        End With
        
        Book = rsT.Bookmark

        strSQL2 = "SELECT * FROM dbo.Menu INNER JOIN dbo.MenuPower ON dbo.Menu.Menue_ID = dbo.MenuPower.MenueID " & _
             "WHERE (dbo.MenuPower.UsrID = N'" & UsrID & "') AND (dbo.MenuPower.PowerUSR = 1) AND (Parant_ID= '" & rsT(0) & "')"
        rst2.Open strSQL2, cnn, adOpenStatic, adLockOptimistic
        Do Until rst2.EOF
            MenuCaption = rst2(2)

            Set SubMenu = NewMenu.CommandBar.Controls _
                      .Add(Type:=msoControlButton)
            With SubMenu
                .Caption = MenuCaption
                .TooltipText = MenuCaption
                .Style = msoButtonIconAndCaption
                .Tag = rst2(0)
                .FaceId = Nz(rst2(3), 0)
                .OnAction = Nz(rst2(4), "")
            End With
            
            rst2.MoveNext
        Loop
        rst2.Close
        rsT.Bookmark = Book
        rsT.MoveNext
    Loop
    
    rsT.Close
    Set rsT = Nothing
    rst2.Close
    Set rst2 = Nothing


End Sub