clsauthority.cls

本系统可用于医院和专业体检中心的健康体检管理

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsAuthority"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private m_dicMenuAccess As Scripting.Dictionary
Private m_blnIsSystemManager As Boolean

'设置访问权限
Public Function SetAuthority(ByVal intManagerID As Integer)
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strGroups As String
    Dim strKey As String, strItem As String
    
    strSQL = "select JSID from RY_Employee" _
            & " where EmployeeID=" & intManagerID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then GoTo ExitLab
    
    strGroups = rstemp("JSID")
    If strGroups = "" Then GoTo ExitLab
    
    '是否系统管理员
    strSQL = "select Count(*) from SET_JS_INDEX" _
            & " where JSID in(" & strGroups & ")" _
            & " and JSMC like '%系统管理员'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp(0) > 0 Then
        m_blnIsSystemManager = True
        GoTo ExitLab
    End If
    
    '提取该权限所能访问的菜单
    strSQL = "select distinct MnuName,BUID from SET_JS_MnuData,SET_MNU_Data" _
            & " where JSID in(" & strGroups & ")" _
            & " and SET_JS_MnuData.MnuID=SET_MNU_DATA.MnuID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        With m_dicMenuAccess
            Do
                strKey = rstemp("MnuName")
                strItem = rstemp("BUID")
                If Not .Exists(strKey) Then
                    m_dicMenuAccess.Add strKey, strItem
                End If
                
                rstemp.MoveNext
            Loop Until rstemp.EOF
        End With
        rstemp.Close
    End If
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    '
End Function

'判断菜单是否可用
Public Function CheckMenuAuthority(ByVal strMenuName As String) As Boolean
    Dim strBUID As String
    
    strBUID = GetBUID(strMenuName)
    If Len(strBUID) = 4 And strBUID Like "1*" Then
        CheckMenuAuthority = True
    End If
End Function

'判断在指定菜单下，指定操作是否被授权
Public Function CheckOperationAuthority(ByVal strMenuName As String, _
        ByVal enuBUID As BUID) As Boolean
    Dim strBUID As String
    Dim blnOK As Boolean
    
    strBUID = GetBUID(strMenuName)
    If Len(strBUID) <> 4 Then GoTo ExitLab
    
    Select Case enuBUID
        Case BUID.BROWSER_W
            If CBool(Val(Mid(strBUID, 1, 1))) Then blnOK = True
        Case BUID.UPDATE_W
            If CBool(Val(Mid(strBUID, 2, 1))) Then blnOK = True
        Case BUID.INSERT_W
            If CBool(Val(Mid(strBUID, 3, 1))) Then blnOK = True
        Case BUID.DELETE_W
            If CBool(Val(Mid(strBUID, 4, 1))) Then blnOK = True
        Case Else
            '
    End Select
    
    If Not blnOK Then
        MsgBox "该操作已被系统管理员禁止！", vbExclamation, "警告"
    End If
    
    CheckOperationAuthority = blnOK
    
    GoTo ExitLab
ExitLab:
    '
End Function

'返回指定菜单的授权代码
Private Function GetBUID(ByVal strMenuName As String)
    Dim strKeys
    Dim i As Integer
    Dim strBUID As String
    
    If m_blnIsSystemManager Then
        strBUID = "1111"
    Else
        With m_dicMenuAccess
            strKeys = .Keys
            For i = 0 To .Count - 1
                If CStr(strKeys(i)) = strMenuName Then
                    strBUID = .Items(i)
                    Exit For
                End If
            Next i
        End With
    End If
    
    GetBUID = strBUID
End Function

'执行命令行
Public Sub ExecuteVBAScript(ByVal strCode As String)
'    Dim scpControl As ScriptControl
'
'    Set scpControl = New ScriptControl
'    strCode = "Sub HelloWorld " & vbCrLf & strCode & vbCrLf & "End Sub"
'    With scpControl
'        .Language = "VBScript"
'        .AddCode strCode
'        .ExecuteStatement "HelloWorld"
'    End With
End Sub

Private Sub Class_Initialize()
    Set m_dicMenuAccess = New Scripting.Dictionary
End Sub

Private Sub Class_Terminate()
    Set m_dicMenuAccess = Nothing
End Sub