VB6应用系统的权限管理

实现方法：建立如下表,对每一个form的操作功能中加入如下的AskRights Function,即可对每一个form及其中的每一项功能进行单独控制，包括菜单项的控制,出错处理请查本人另一文档

'  表结构说明:

'  表:users_frm(Form设定)  f001 IDENTITY Form ID号,   f002 V20  Form名,  f003 V50 form说明,  f004 V50  对应菜单名,   f005 V2  新增,  f006 V2 存盘,  f007 V2 删除,  f008 V2  修改,  f009 V2  查询,  f010 V2  打印,  f011 V2  特殊键1,  f012 V2  特殊键2,   f013 V2  特殊键3,   f014 V2  特殊键4,   f015 V2  特殊键5

'  表:users_k(组别表)    f001 V20  组别编码, f002 V20 名称,   f003 V50 说明

'  表:users_kx(组别从表)   f001 V20  组别编码, f002 V20 form名, f003 V2  菜单可见否,  f004 V2 菜单是否有效,  f005 V2  新增,  f006 V2 存盘,  f007 V2 删除,  f008 V2  修改,  f009 V2  查询,  f010 V2  打印,  f011 V2  特殊键1,  f012 V2  特殊键2,   f013 V2  特殊键3,   f014 V2  特殊键4,   f015 V2  特殊键5

'  表:users_x(用户权限表)  f001 V20  用户编码, f002 V20 form名, f003 V2  菜单可见否,  f004 V2 菜单是否有效,  f005 V2  新增,  f006 V2 存盘,  f007 V2 删除,  f008 V2  修改,  f009 V2  查询,  f010 V2  打印,  f011 V2  特殊键1,  f012 V2  特殊键2,   f013 V2  特殊键3,   f014 V2  特殊键4,   f015 V2  特殊键5'

'  表:users (用户表)       f001 IDENTITY 用户内部ID号  f002 V20  用户编码,  f003 V20  名称,   f004 V20  密码,     f005 V20  组别,   f006 V50  说明

'======菜单控制===========================

Function ControlMENU(userID As String, MenuName As String) As String

    Dim intResult As Integer

    Dim strSQL As String

    Dim AdoRes As New ADODB.Recordset

    On Error GoTo ErrorHandle

    strSQL = "select a.f002 as f1,b.f004 as f2,a.f003 as f3,a.f004 as f4 from users_x a,users_frm b where a.f002=b.f002 and a.f001='" & userID & "' and b.f004='" & MenuName & "'"

    Set AdoRes = Cn.Execute(strSQL)

    If AdoRes.EOF Then

        'MsgBox "此用户没有定义权限，请联系系统管理员设定!!!", vbOKOnly + vbCritical, "警告"

        ControlMENU = Empty

        GoTo PROC_EXIT

    End If

    ControlMENU = IIf(IsNull(AdoRes.Fields("f3")), "", AdoRes.Fields("f3")) & "~" & IIf(IsNull(AdoRes.Fields("f4")), "", AdoRes.Fields("f4"))

PROC_EXIT:

    Set AdoRes = Nothing

    Exit Function

ErrorHandle:

    Call ShowError("Permissons", "ControlMenu", err.Number, err.Description, "Y")

End Function

'======各项功能控制===========================

Function AskRights(userID As String, FormName As String, FuncName As String) As Boolean

    ' UserCode 用户ID号,  FormName Form名称,   FuncName  功能名称

    ' 功能名称说明:

    ' Insert  新增按钮

    ' Save    存盘按钮

    ' Delete  删除按钮

    ' Modify  修改按钮

    ' Query    查询按钮

    ' Print   打印按钮

    ' Key1    特殊按钮1

    ' Key2    特殊按钮2

    ' Key3    特殊按钮3

    ' Key4    特殊按钮4

    ' Key5    特殊按钮5

    Dim intResult As Integer

    Dim strSQL As String

    Dim AdoRes As New ADODB.Recordset

    Dim FuncString As String

    On Error GoTo ErrorHandle

    strSQL = "select f005,f006,f007,f008,f009,f010,f011,f012,f013,f014,f015 from users_x where f001='" & sUserID & "' and f002='" & FormName & "'"

    'Debug.Print strSQL

    Set AdoRes = Cn.Execute(strSQL)

    If AdoRes.EOF Then

        AskRights = False

        GoTo PROC_EXIT

    End If

    Select Case UCase(FuncName)

    Case "INSERT"

        If UCase(IIf(IsNull(AdoRes.Fields("f005")), "", AdoRes.Fields("f005"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "SAVE"

        If UCase(IIf(IsNull(AdoRes.Fields("f006")), "", AdoRes.Fields("f006"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "DELETE"

        If UCase(IIf(IsNull(AdoRes.Fields("f007")), "", AdoRes.Fields("f007"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "MODIFY"

        If UCase(IIf(IsNull(AdoRes.Fields("f008")), "", AdoRes.Fields("f008"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "QUERY"

        If UCase(IIf(IsNull(AdoRes.Fields("f009")), "", AdoRes.Fields("f009"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "PRINT"

        If UCase(IIf(IsNull(AdoRes.Fields("f010")), "", AdoRes.Fields("f010"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "KEY1"

        If UCase(IIf(IsNull(AdoRes.Fields("f011")), "", AdoRes.Fields("f011"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "KEY2"

        If UCase(IIf(IsNull(AdoRes.Fields("f012")), "", AdoRes.Fields("f012"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "KEY3"

        If UCase(IIf(IsNull(AdoRes.Fields("f013")), "", AdoRes.Fields("f013"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "KEY4"

        If UCase(IIf(IsNull(AdoRes.Fields("f014")), "", AdoRes.Fields("f014"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    Case "KEY5"

        If UCase(IIf(IsNull(AdoRes.Fields("f015")), "", AdoRes.Fields("f015"))) = "Y" Then

            AskRights = True

        Else

            AskRights = False

        End If

    End Select

    'If AskRights = False Then MsgBox "您没有此项操作的权限 !   ", vbInformation, "帮助信息"

PROC_EXIT:

    Set AdoRes = Nothing

    Exit Function

ErrorHandle:

    Call ShowError("Permissons", "AskRights", err.Number, err.Description, "Y")

End Function

Public Sub SetMenu(obj As Object, userID As String)

    ' 设置菜单

    Dim MenuName As String

    Dim YorN As String

    Dim MenuObj As Object

    On Error GoTo ErrorHandle

    For Each MenuObj In obj.Controls

        Select Case TypeName(MenuObj)

        Case "Menu"

            YorN = UCase(ControlMENU(userID, MenuObj.name))

            If Len(YorN) = 0 Then GoTo lap

            If Mid(YorN, 1, InStr(1, YorN, "~") - 1) = "N" Then

                MenuObj.Visible = False

            ElseIf Mid(YorN, 1, InStr(1, YorN, "~") - 1) = "Y" Then

                MenuObj.Visible = True

            End If

            If Mid(YorN, InStr(1, YorN, "~") + 1, 1) = "N" Then

                MenuObj.Enabled = False

            ElseIf Mid(YorN, InStr(1, YorN, "~") + 1, 1) = "Y" Then

                MenuObj.Enabled = True

            End If

lap:

        End Select

    Next

Exit Sub

ErrorHandle:

    Call ShowError("Permissons", "SetMenu", err.Number, err.Description, "Y")

End Sub

'此过程放在frmMain的Form_load中

Public Sub SetMenu(obj As Object, userID As String)

    ' 设置菜单

    Dim MenuName As String

    Dim YorN As String

    Dim MenuObj As Object

    On Error GoTo ErrorHandle

    For Each MenuObj In obj.Controls

        Select Case TypeName(MenuObj)

        Case "Menu"

            YorN = UCase(ControlMENU(userID, MenuObj.name))

            If Len(YorN) = 0 Then GoTo lap

            If Mid(YorN, 1, InStr(1, YorN, "~") - 1) = "N" Then

                MenuObj.Visible = False

            ElseIf Mid(YorN, 1, InStr(1, YorN, "~") - 1) = "Y" Then

                MenuObj.Visible = True

            End If

            If Mid(YorN, InStr(1, YorN, "~") + 1, 1) = "N" Then

                MenuObj.Enabled = False

            ElseIf Mid(YorN, InStr(1, YorN, "~") + 1, 1) = "Y" Then

                MenuObj.Enabled = True

            End If

lap:

        End Select

    Next

Exit Sub

ErrorHandle:

    Call ShowError("Permissons", "SetMenu", err.Number, err.Description, "Y")

End Sub