frmjsdy.frm

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

    End Select
    
    TxtJSSM.Locked = False
    cmdModify.Enabled = False
    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    cmdAdd.Enabled = False
    mStatus = "Modify"
End Sub

Private Sub cmdSave_Click()
    Dim Status
    Dim i As Integer
    Dim cmdTemp As ADODB.Command
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim tmpJSID As Integer
    Dim itemX As ListItem

On Error GoTo ErrMsg
    If TxtJSMC.Text = "" Then
        MsgBox "请输入角色名称", vbInformation, "提示"
        Exit Sub
    End If
    
    Set cmdTemp = New ADODB.Command
    Set cmdTemp.ActiveConnection = GCon
    If mStatus = "Add" Then
        Set rstemp = GCon.Execute("select * from set_js_index where jsmc='" & TxtJSMC.Text & "'")
        If rstemp.RecordCount >= 1 Then
            MsgBox "该角色名称已经存在！", vbExclamation, "错误"
            Exit Sub
        End If
        '产生一个新的JSID
        Set rstemp = New ADODB.Recordset
        strSQL = "select MAX(JSID) as maxJSID from SET_JS_Index"
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount = 0 Or IsNull(rstemp("maxJSID")) Then
            tmpJSID = 1
        Else
            tmpJSID = rstemp("maxJSID") + 1
        End If
        strSQL = "insert into SET_JS_Index(JSID,JSMC,JSSM) values(" & tmpJSID & ",'" & TxtJSMC.Text _
                & "','" & TxtJSSM.Text & "')"
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        rstemp.Close
        For i = 1 To TvwMNU.Nodes.Count
            If TvwMNU.Nodes(i).Checked = True And _
                (Left(TvwMNU.Nodes(i).Key, 1) = "C" Or Left(TvwMNU.Nodes(i).Key, 1) = "W") Then
                strSQL = "insert into SET_JS_MNUData(JSID,mnuID) VALUES(" & tmpJSID & "," _
                        & CInt(Mid(TvwMNU.Nodes(i).Key, 2)) & ")"
                cmdTemp.CommandText = strSQL
                cmdTemp.Execute
            End If
        Next i
        Set itemX = LvwJS.ListItems.Add(LvwJS.ListItems.Count + 1, "W" & tmpJSID, TxtJSSM.Text)
        itemX.SubItems(1) = TxtJSMC.Text
        Set LvwJS.SelectedItem = itemX
        LvwJS_Click
    ElseIf mStatus = "Modify" Then
        '先删除该角色所有数据
        strSQL = "delete from SET_JS_MNUData where JSID=" & CInt(Mid(LvwJS.SelectedItem.Key, 2))
        cmdTemp.CommandText = strSQL
        cmdTemp.Execute
        For i = 1 To TvwMNU.Nodes.Count
            If TvwMNU.Nodes(i).Checked = True And _
            (Left(TvwMNU.Nodes(i).Key, 1) = "C" Or Left(TvwMNU.Nodes(i).Key, 1) = "W") Then
                strSQL = "insert into SET_JS_MNUData(JSID,mnuID) VALUES(" & CInt(Mid(LvwJS.SelectedItem.Key, 2)) & "," _
                        & CLng(Mid(TvwMNU.Nodes(i).Key, 2)) & ")"
                cmdTemp.CommandText = strSQL
                cmdTemp.Execute
            End If
        Next i
        MsgBox "修改成功", vbInformation
    End If
    
    mStatus = "Browser"
    
    cmdSave.Enabled = False
    cmdAdd.Enabled = True
    cmdModify.Enabled = True
    cmdDelete.Enabled = True
    LvwJS_Click
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, "保存角色数据时出现错误：" & vbCrLf & Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
End Sub

Private Sub Form_Load()
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsChild As ADODB.Recordset
    Dim tmpNode, tmpNodeChild, rootNode As Node
    Dim i As Integer
    Dim itemX As ListItem
    
    Screen.MousePointer = vbArrowHourglass
    mStatus = "Browser"
    '在tvwMNU中添加现有的功能
    If genuVersion = WLB Then
        strSQL = "select * from SET_MNU_DATA WHERE (mnuType='ZQY' or mnuType='QF') and Display=1 and FatherID=0 order by mnuID"
    ElseIf genuVersion = ZYB Or genuVersion = BZB Or genuVersion = PJB Then
        strSQL = "select * from SET_MNU_DATA WHERE mnuType='ZYBBZBPJB' and Display=1 and FatherID=0 order by mnuID"
    End If
    Set rootNode = TvwMNU.Nodes.Add(, , "R0", "全部功能")

    '找出所有父节点
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        Do While Not rstemp.EOF
            Set tmpNode = TvwMNU.Nodes.Add("R0", tvwChild, "W" & rstemp("mnuID"), rstemp("mnuName"))
            tmpNode.Text = rstemp("mnuCaption")
            '添加属于该父节点的子节点
            If genuVersion = WLB Then
                strSQL = "select * from SET_MNU_DATA WHERE (mnuType='ZQY' or mnuType='QF') and Display=1" _
                        & " and FatherID=" & rstemp("mnuID") & " order by mnuID"
            ElseIf genuVersion = ZYB Or genuVersion = BZB Or genuVersion = PJB Then
                strSQL = "select * from SET_MNU_DATA WHERE mnuType='ZYBBZBPJB' and Display=1" _
                            & " and FatherID=" & rstemp("mnuID") & " order by mnuID"
            End If
            Set rsChild = New ADODB.Recordset
            rsChild.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            '开始添加子节点
            If rsChild.RecordCount > 0 Then
                rsChild.MoveFirst
                Do While Not rsChild.EOF
                    Set tmpNodeChild = TvwMNU.Nodes.Add(tmpNode.Key, tvwChild, "C" & rsChild("mnuID"), rsChild("mnuName"))
                    tmpNodeChild.Text = rsChild("mnuCaption")
                    rsChild.MoveNext
                Loop
            End If
            rstemp.MoveNext
        Loop
    End If
    '在所有父节点下添加子节点
    For i = 1 To TvwMNU.Nodes.Count
        '展开全部节点。
        TvwMNU.Nodes(i).Expanded = True
    Next i
    
    '在列表框中添加现有的角色
    strSQL = "select * from SET_JS_Index order by jsid"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            Set itemX = LvwJS.ListItems.Add(, "W" & rstemp("JSID"), rstemp("JSmc"))
            itemX.SubItems(1) = rstemp("JSMC")

            rstemp.MoveNext
        Loop
        '选中第一个角色
        Set LvwJS.SelectedItem = LvwJS.ListItems(1)
        LvwJS_Click
        '初始化命令按钮状态
        cmdAdd.Enabled = True
        cmdModify.Enabled = True
        cmdSave.Enabled = False
        cmdDelete.Enabled = True
        GoTo ExitLab
    End If
    
    '初始化命令按钮状态
    cmdAdd.Enabled = True
    cmdModify.Enabled = False
    cmdSave.Enabled = False
    cmdDelete.Enabled = False
    
    GoTo ExitLab
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub LvwJS_Click()
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    mStatus = "Browser"
    
    If LvwJS.ListItems.Count > 0 Then
        '在tvwMNU中将该角色有权限的功能打勾
        ClearNodes
        '显示角色基本信息
        strSQL = "select * from SET_JS_Index where JSID=" & CInt(Mid(LvwJS.SelectedItem.Key, 2))
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        TxtJSMC.Text = rstemp("JSMC")
        TxtJSSM.Text = rstemp("JSSM") & ""
        
        strSQL = "select * from SET_JS_MNUData where JSID=" _
                & CInt(Val(Mid(LvwJS.SelectedItem.Key, 2)))
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount > 0 Then
            rstemp.MoveFirst
            Do While Not rstemp.EOF
                For i = 2 To TvwMNU.Nodes.Count
                    If rstemp("mnuID") = CLng(Mid(TvwMNU.Nodes(i).Key, 2)) Then
                        TvwMNU.Nodes(i).Checked = True
                    End If
                Next
                rstemp.MoveNext
            Loop
        End If
        cmdAdd.Enabled = True
        cmdModify.Enabled = True
        cmdSave.Enabled = False
        cmdDelete.Enabled = True
    End If
    
    EnableJSInput False
End Sub

Private Sub TvwMNU_Click()
    If mStatus = "Browser" Then
        TvwMNU.SelectedItem.Checked = Not TvwMNU.SelectedItem.Checked
    End If

End Sub

Private Sub TvwMNU_NodeCheck(ByVal Node As MSComctlLib.Node)
    Dim tmpNode As Node
    Dim i As Integer
    
    If mStatus = "Browser" Then
        Set TvwMNU.SelectedItem = Node
        Node.Checked = Not Node.Checked
        Exit Sub
    ElseIf mStatus = "Add" Or mStatus = "Modify" Then
        Set TvwMNU.SelectedItem = Node
        If Left(Node.Key, 1) = "W" Then
            For i = 2 To TvwMNU.Nodes.Count
                If TvwMNU.Nodes(i).Parent = Node Then
                    If Node.Checked = True Then
                        TvwMNU.Nodes(i).Checked = True
                    Else
                        TvwMNU.Nodes(i).Checked = False
                    End If
                End If
            Next
        ElseIf Left(Node.Key, 1) = "C" Then
            If Node.Checked = True Then
                Node.Parent.Checked = True
            End If
'            Node.Parent.Checked = Node.Checked
        End If
    End If
    
End Sub

Private Sub TvwMNU_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim tmpNode As Node
    Dim i As Integer
    
    If mStatus = "Browser" Then
        Set TvwMNU.SelectedItem = Node
        Node.Checked = Not Node.Checked
        Exit Sub
    ElseIf mStatus = "Add" Or mStatus = "Modify" Then
        Set TvwMNU.SelectedItem = Node
        If Left(Node.Key, 1) = "W" Then
            For i = 2 To TvwMNU.Nodes.Count
                If TvwMNU.Nodes(i).Parent = Node Then
                    If Node.Checked = True Then
                        TvwMNU.Nodes(i).Checked = True
                    Else
                        TvwMNU.Nodes(i).Checked = False
                    End If
                End If
            Next
        ElseIf Left(Node.Key, 1) = "C" Then
            If Node.Checked = True Then
                Node.Parent.Checked = True
            End If
'            Node.Parent.Checked = Node.Checked
        End If
    End If
    
End Sub

Private Sub ClearNodes()
    Dim i As Integer
    For i = 1 To TvwMNU.Nodes.Count
        TvwMNU.Nodes(i).Checked = False
    Next
End Sub

Private Sub RefreshJS()
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itemX As ListItem
    
    LvwJS.ListItems.Clear
    '在列表框中添加现有的角色
    strSQL = "select * from SET_JS_Index"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            Set itemX = LvwJS.ListItems.Add(, "W" & rstemp("JSID"), rstemp("JSSM"))
            itemX.SubItems(1) = rstemp("JSMC")

            rstemp.MoveNext
        Loop
        '选中第一个角色
        Set LvwJS.SelectedItem = LvwJS.ListItems(1)
        LvwJS_Click
        '初始化命令按钮状态
        cmdAdd.Enabled = True
        cmdModify.Enabled = True
        cmdSave.Enabled = False
        cmdDelete.Enabled = True
        
    End If

End Sub

Private Sub EnableJSInput(ByVal blnFlag As Boolean)
    TxtJSMC.Enabled = blnFlag
    TxtJSSM.Enabled = blnFlag
End Sub