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