frmauthority.frm

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

ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdModify_Click()
    Dim itmSelected As ListItem
    
    '权限验证
    If g_blnIsNew Then
        If Not g_clsAuthority.CheckOperationAuthority(m_strMenu, UPDATE_W) Then GoTo ExitLab
    End If
    '验证完毕
    
    '是否有选择
    If lvwJS.SelectedItem Is Nothing Then GoTo ExitLab
    '是否系统管理员
    Set itmSelected = lvwJS.SelectedItem
    If itmSelected.Text = "系统管理员" Then
        MsgBox "系统管理员 是系统内置角色，拥有所有操作权限，不能进行修改！", _
                vbExclamation, "警告"
        GoTo ExitLab
    End If
    
    Call lvwJS_Click
    Call EnableCommand(False, True)
    Call EnableInput(True)
    
    If CBool(itmSelected.Tag) Then
        txtJSMC.Enabled = False '系统自定义角色不能修改名称
        txtJSSM.SetFocus
    Else
        txtJSMC.SetFocus
    End If
    
    m_blnEdit = True
    m_enuOperation = Modify
    
    GoTo ExitLab
ExitLab:
    '
End Sub

Private Sub cmdSave_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strJSMC As String
    Dim intJSID As Integer
    Dim dtmNow As Date
    Dim intIndex As Integer
    Dim strKey As String
    Dim itmTemp As ListItem
    Dim blnHave As Boolean
    
    Me.MousePointer = vbHourglass
    
    strJSMC = Trim(txtJSMC.Text)
    txtJSMC.Text = strJSMC
    '是否有输入
    If strJSMC = "" Then
        MsgBox "请输入角色名称！", vbInformation, "提示"
        txtJSMC.SetFocus
        GoTo ExitLab
    End If
    
    '角色名称是否重复
    If strJSMC <> txtJSMC.Tag Then
        strSQL = "select Count(*) from SET_JS_INDEX" _
                & " where JSMC='" & strJSMC & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
        If rsTemp(0) > 0 Then
            MsgBox "您输入的角色名称已经存在，请核对后重新输入！", vbInformation, "提示"
            txtJSMC.SetFocus
            GoTo ExitLab
        End If
    End If
    
    '启动事务
    GCon.BeginTrans
    On Error GoTo RollBack
    '添加还是修改
    If m_enuOperation = Add Then
        intJSID = CInt(GetAvailableID("SET_JS_INDEX", "JSID", True))
        '插入一条空记录
        strSQL = "insert into SET_JS_INDEX(JSID) values(" & intJSID & ")"
        GCon.Execute strSQL
    Else
        intJSID = Mid(lvwJS.SelectedItem.Key, 2)
    End If
    
    '更新其余字段
    dtmNow = Now
    strSQL = "update SET_JS_INDEX set" _
            & " JSMC='" & strJSMC & "'" _
            & ",JSSM='" & txtJSMC.Text & "'"
    If m_enuOperation = Add Then
        strSQL = strSQL & ",JLSJ='" & dtmNow & "'" _
                & ",BuildManager=" & gintManagerID _
                & ",JSDefault=0" '用户添加的角色均非系统角色
    End If
    strSQL = strSQL & ",XGSJ='" & dtmNow & "'" _
            & ",ModifyManager=" & gintManagerID _
            & " where JSID=" & intJSID
    GCon.Execute strSQL
    
    '写入角色权限表
    strSQL = "delete from SET_JS_MnuData" _
            & " where JSID=" & intJSID
    GCon.Execute strSQL
    
    With tvwMenu
        For intIndex = 1 To .Nodes.Count
            If .Nodes(intIndex).Checked Then
                strKey = .Nodes(intIndex).Key
                If Left(strKey, 1) = "M" Or Left(strKey, 1) = "Y" Then
                    If Left(strKey, 1) = "Y" Then
                        If Len(.Nodes(intIndex).Tag) <> 4 Or .Nodes(intIndex).Tag = "0000" Then
                            Set .SelectedItem = .Nodes(intIndex)
                            Call tvwMenu_NodeClick(.SelectedItem)
                            MsgBox "请设置 " & .Nodes(intIndex).Text & " 的访问权限！", _
                                    vbInformation, "提示"
                            GoTo RollBack
                        Else
                            blnHave = True
                        End If
                    End If
                    strSQL = "insert into SET_JS_MnuData(JSID,MnuID,BUID) values(" _
                            & intJSID _
                            & "," & CInt(Val(Mid(.Nodes(intIndex).Key, 2))) _
                            & ",'" & .Nodes(intIndex).Tag & "'" _
                            & ")"
                    GCon.Execute strSQL
                End If
            End If
        Next intIndex
    End With
    '是否有选择
    If Not blnHave Then
        MsgBox "请设置角色 " & strJSMC & " 的访问权限！", vbInformation, "提示"
        GoTo RollBack
    End If
    
    '提交事务
    GCon.CommitTrans
    On Error GoTo ErrMsg
    
    '修改左侧的列表
    With lvwJS
        If m_enuOperation = Add Then
            Set itmTemp = .ListItems.Add(, HEADER & intJSID, strJSMC)
            itmTemp.Tag = "False"
            Set .SelectedItem = itmTemp
        Else
            .SelectedItem.Text = strJSMC
        End If
        Call EnableInput(False)
        Call EnableCommand(True, False)
    End With
    
    m_blnEdit = False
    
    GoTo ExitLab
RollBack:
    GCon.RollbackTrans
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsJS As ADODB.Recordset
    Dim rsParent As ADODB.Recordset
    Dim rsChild As ADODB.Recordset
    Dim itmTemp As ListItem
    Dim nodTemp As Node
    
    Screen.MousePointer = vbHourglass
    
    '显示所有角色
    strSQL = "select JSID,JSMC,JSDefault from SET_JS_Index" _
            & " order by JSMC"
    Set rsJS = New ADODB.Recordset
    rsJS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsJS.EOF Then
        With lvwJS
            Do
                Set itmTemp = .ListItems.Add(, HEADER & rsJS("JSID"), rsJS("JSMC"))
                itmTemp.Tag = rsJS("JSDefault")
                
                rsJS.MoveNext
            Loop While Not rsJS.EOF
            rsJS.Close
            
            Set .SelectedItem = .ListItems(1)
        End With
    End If
    
    '加载所有菜单
    strSQL = "select MnuID,MnuCaption from SET_MNU_DATA" _
            & " where FatherID=0" _
            & " order by MnuID"
    Set rsParent = New ADODB.Recordset
    rsParent.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsParent.EOF Then
        With tvwMenu
            '添加根节点
            Set nodTemp = .Nodes.Add(, , HEADER, "全部功能")
            nodTemp.Expanded = True
            Do
                Set nodTemp = .Nodes.Add(HEADER, tvwChild, "M" & rsParent("MnuID"), rsParent("MnuCaption"))
                nodTemp.Expanded = True
                
                '添加子菜单
                strSQL = "select MnuID,MnuCaption from SET_MNU_DATA" _
                        & " where FatherID=" & rsParent("MnuID") _
                        & " order by MnuID"
                Set rsChild = New ADODB.Recordset
                rsChild.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rsChild.EOF Then
                    Do
                        Set nodTemp = .Nodes.Add("M" & rsParent("MnuID"), tvwChild, "Y" & rsChild("MnuID"), rsChild("MnuCaption"))
                        
                        rsChild.MoveNext
                    Loop While Not rsChild.EOF
                    rsChild.Close
                End If
                
                rsParent.MoveNext
            Loop While Not rsParent.EOF
            rsParent.Close
        End With
    End If
    
    Call lvwJS_Click
    Call EnableInput(False)
    m_blnEdit = False
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'启用/禁用角色输入
Private Sub EnableInput(ByVal blnFlag As Boolean)
    txtJSMC.Enabled = blnFlag
    txtJSSM.Enabled = blnFlag
    tvwMenu.CausesValidation = False
    fraAccess.Enabled = blnFlag
End Sub

Private Sub lvwJS_Click()
On Error GoTo ErrMsg
    Dim strSQL As String
    Dim rsJS As ADODB.Recordset
    Dim intJSID As Integer
    Dim i As Integer
    Dim blnExist As Boolean
    
    Me.MousePointer = vbArrowHourglass
    
    Call EnableInput(False)
    '是否有选择
    If lvwJS.SelectedItem Is Nothing Then GoTo ExitLab
    
    '记录角色ID
    intJSID = CInt(Val(Mid(lvwJS.SelectedItem.Key, 2)))
    '获取角色信息
    strSQL = "select JSMC,JSSM from SET_JS_Index" _
            & " where JSID=" & intJSID
    Set rsJS = New ADODB.Recordset
    rsJS.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rsJS.EOF Then
        txtJSMC.Text = rsJS("JSMC")
        txtJSMC.Tag = rsJS("JSMC")
        txtJSSM.Text = rsJS("JSSM") & ""
        
        rsJS.Close
    End If
    
    '获取当前角色可以访问的菜单
    strSQL = "select MnuID,BUID from SET_JS_MnuData" _
            & " where JSID=" & intJSID _
            & " order by MnuID"
    Set rsJS = New ADODB.Recordset
    rsJS.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not rsJS.EOF Then
        With tvwMenu
            For i = 1 To .Nodes.Count
                blnExist = False
                rsJS.MoveFirst
                Do
                    If Mid(.Nodes(i).Key, 2) = CStr(rsJS("MnuID")) Then
                        blnExist = True
                        Exit Do
                    End If
                    
                    rsJS.MoveNext
                Loop While Not rsJS.EOF
                '是否存在
                If Not blnExist Then
                    .Nodes(i).Checked = False
                    .Nodes(i).Tag = ""
                Else
                    .Nodes(i).Checked = True
                    .Nodes(i).Tag = rsJS("BUID")
                End If
            Next i
            rsJS.Close
        End With
    End If
    
    If Not (tvwMenu.SelectedItem Is Nothing) Then Call tvwMenu_NodeClick(tvwMenu.SelectedItem)
    Call EnableCommand(True, False)
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    m_blnEdit = False
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwJS_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Then Call lvwJS_Click
End Sub

Private Sub tvwMenu_NodeCheck(ByVal Node As MSComctlLib.Node)
    If Left(Node.Key, 1) <> "Y" Then
        fraAccess.Visible = False
    Else
        fraAccess.Visible = True
    End If
    
    If m_blnEdit Then
        Call ManipunateCheckTree(tvwMenu, Node)
    End If
End Sub

Private Sub tvwMenu_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim strBUID As String
    
    If Left(Node.Key, 1) <> "Y" Then
        fraAccess.Visible = False
    Else
        fraAccess.Visible = True
    End If
    
    strBUID = Node.Tag & ""
    If Len(strBUID) <> 4 Then strBUID = "0000"
    
    chkUpdate.Value = IIf(CBool(Mid(strBUID, 2, 1)), vbChecked, vbUnchecked)
    chkInsert.Value = IIf(CBool(Mid(strBUID, 3, 1)), vbChecked, vbUnchecked)
    chkDelete.Value = IIf(CBool(Mid(strBUID, 4, 1)), vbChecked, vbUnchecked)
    chkBrowser.Value = IIf(CBool(Mid(strBUID, 1, 1)), vbChecked, vbUnchecked)
    
    GoTo ExitLab
ExitLab:
    '
End Sub

'清除录入
Private Sub ClearInput()
    txtJSMC.Text = ""
    txtJSMC.Tag = ""
    txtJSSM.Text = ""
End Sub

'启用/禁用按钮
Private Sub EnableCommand(ByVal blnFlag As Boolean, Optional ByVal blnEdit As Boolean = False)
    cmdAdd.Enabled = blnFlag
    cmdModify.Enabled = blnFlag
    If blnEdit Then
        cmdSave.Enabled = True
    Else
        cmdSave.Enabled = False
    End If
    cmdDelete.Enabled = blnFlag
End Sub

'是否有BUID的后三种权限
Private Sub CheckBUID()
    If chkUpdate.Value = vbChecked Or chkInsert.Value = vbChecked _
            Or chkDelete.Value = vbChecked Then chkBrowser.Value = vbChecked
End Sub

'记录BUID
Private Sub WriteBUID()
    Dim strBUID As String
    
    If tvwMenu.SelectedItem Is Nothing Then GoTo ExitLab
    
    With tvwMenu
        If Left(.SelectedItem.Key, 1) <> "Y" Then GoTo ExitLab
        
        strBUID = IIf(chkBrowser.Value = vbChecked, "1", "0") _
                & IIf(chkUpdate.Value = vbChecked, "1", "0") _
                & IIf(chkInsert.Value = vbChecked, "1", "0") _
                & IIf(chkDelete.Value = vbChecked, "1", "0")
        .SelectedItem.Tag = strBUID
    End With
    
    GoTo ExitLab
ExitLab:
    '
End Sub