实现方法：建立如下表,对每一个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
本文作者:网友 来源:网络http://blog.csdn.net/fangke/
CIO之家 www.ciozj.com 微信公众号:imciow