frmoprinfo.frm

一套简易的MIS系统。带SQLServer数据库。供参考。

    Dim rsTemp                     As New ADODB.Recordset
    Dim iIndex                     As Integer
    Dim strSQL                     As String
    strSQL = "Select * from tbCCFunction Where fLevel=1 Order By fCode "
    Set rsTemp = DBCN.Execute(strSQL)
    If rsTemp.EOF = False Then
        iIndex = 1
        lstLimited1.ListItems.Clear
        lstLimited1.LabelEdit = lvwManual
        lstLimited1.View = lvwIcon
        Set lstLimited1.Icons = ImageList3
        Do Until rsTemp.EOF
            If strLimited1(Val(rsTemp.Fields("fCode"))) = 1 Then
                lstLimited1.ListItems.Add iIndex, , rsTemp.Fields("fName") & "[" & rsTemp.Fields("fCode") & "]", 4
            Else
                lstLimited1.ListItems.Add iIndex, , rsTemp.Fields("fName") & "[" & rsTemp.Fields("fCode") & "]", 5
            End If
            rsTemp.MoveNext
            iIndex = iIndex + 1
        Loop
    End If
    
End Function

'显示二级
Private Function getLimited2(strInfo As String)
    
    Dim rsTemp                     As New ADODB.Recordset
    Dim iIndex                     As Integer
    Dim strSQL                     As String
    strSQL = "Select * from tbCCFunction Where fLevel=2 And fCode Like '" & strInfo & "%' Order By fCode "
    Set rsTemp = DBCN.Execute(strSQL)
    If rsTemp.EOF = False Then
        iIndex = 1
        lstLimited2.ListItems.Clear
        lstLimited2.LabelEdit = lvwManual
        lstLimited2.View = lvwIcon
        Set lstLimited2.Icons = ImageList3
        Do Until rsTemp.EOF
            If strLimited2(Val(Right(rsTemp.Fields("fCode"), 4))) = 1 Then
                lstLimited2.ListItems.Add iIndex, , rsTemp.Fields("fName") & "[" & rsTemp.Fields("fCode") & "]", 4
            Else
                lstLimited2.ListItems.Add iIndex, , rsTemp.Fields("fName") & "[" & rsTemp.Fields("fCode") & "]", 5
            End If
            rsTemp.MoveNext
            iIndex = iIndex + 1
        Loop
    End If
    
End Function

'获取权限
Private Sub getLimit(strInfo As String)
    
    Dim rsTemp                     As New ADODB.Recordset
    Dim iIndex                     As Integer
    
    Set rsTemp = DBCN.Execute("Select * from tbCcOper Where Oper_ID='" & strInfo & "' Order By Oper_ID")
    If rsTemp.EOF = False Then
        For iIndex = 1 To Len(rsTemp.Fields("MainLimit"))
            strLimited1(iIndex) = Mid(rsTemp.Fields("MainLimit"), iIndex, 1)
        Next
        For iIndex = 1 To Len(rsTemp.Fields("TwoLimit"))
            strLimited2(iIndex) = Mid(rsTemp.Fields("TwoLimit"), iIndex, 1)
        Next
    End If
    
End Sub

Private Sub lstLimited1_Click()

    strOpr_Limited = tString(lstLimited1.SelectedItem.Text, "[", "]", 0)
    lstLimited2.ListItems.Clear
    getLimited2 strOpr_Limited
    
End Sub

'生成权限
Private Sub lstLimited1_DblClick()
    
    Dim iLimited                  As Integer
    Dim iIndex                    As Integer
    Dim strInfo                   As String
    Dim strInfo1                  As String
    Dim rsTemp                    As New ADODB.Recordset
    
    strOpr_Limited = tString(lstLimited1.SelectedItem.Text, "[", "]", 0)
    strInfo = ""
    
    If lstLimited1.SelectedItem.Icon = 4 Then
        lstLimited1.SelectedItem.Icon = 5
        iLimited = 0
    Else
        lstLimited1.SelectedItem.Icon = 4
        iLimited = 1
    End If
    
    '如果主要功能权限被锁死时，停止二级功能使用权限
    Set rsTemp = DBCN.Execute("Select * from tbCCFunction Where left(fCode,4)='" & strOpr_Limited & "' And fLevel=2 ")
    If rsTemp.EOF = False Then
        Do Until rsTemp.EOF
            strLimited2(Val(Right(rsTemp.Fields("fCode"), 4))) = iLimited
            rsTemp.MoveNext
        Loop
    End If
    strLimited1(Val(strOpr_Limited)) = iLimited
    For iIndex = 0 To UBound(strLimited1)
        If strLimited1(iIndex) <> "" Then
            strInfo = strInfo & strLimited1(iIndex)
        End If
    Next
    strInfo1 = ""
    For iIndex = 0 To UBound(strLimited2)
        If strLimited2(iIndex) <> "" Then
            strInfo1 = strInfo1 & strLimited2(iIndex)
        End If
    Next
    DBCN.Execute "Update tbCcOper Set MainLimit='" & strInfo & "',TwoLimit='" & strInfo1 & "' Where Oper_ID='" & strOpr_Update & "' "
    getLimited2 strOpr_Limited
    
End Sub

Private Sub lstLimited2_DblClick()
    
    Dim iLimited                  As Integer
    Dim strInfo                   As String
    Dim rsTemp                    As New ADODB.Recordset
    
    strInfo = tString(lstLimited2.SelectedItem.Text, "[", "]", 0)
   
    If lstLimited2.SelectedItem.Icon = 4 Then
        lstLimited2.SelectedItem.Icon = 5
        iLimited = 0
    Else
        lstLimited2.SelectedItem.Icon = 4
        iLimited = 1

    End If
    Set rsTemp = DBCN.Execute("Select * from tbCCFunction Where left(fCode,4)='" & Left(strInfo, 4) & "' And fLevel=1 ")
    '如果主要功能权限被锁死时，停止二级功能使用权限
    If rsTemp.EOF = False Then
        Do Until rsTemp.EOF
            strLimited1(Val(Left(rsTemp.Fields("fCode"), 4))) = iLimited
            rsTemp.MoveNext
        Loop
    End If
    strLimited2(Val(Right(strInfo, 4))) = iLimited
    strInfo = ""
    For iIndex = 0 To UBound(strLimited1)
        If strLimited1(iIndex) <> "" Then
            strInfo = strInfo & strLimited1(iIndex)
        End If
    Next
    strInfo1 = ""
    For iIndex = 0 To UBound(strLimited2)
        If strLimited2(iIndex) <> "" Then
            strInfo1 = strInfo1 & strLimited2(iIndex)
        End If
    Next
    DBCN.Execute "Update tbCcOper Set MainLimit='" & strInfo & "',TwoLimit='" & strInfo1 & "' Where Oper_ID='" & strOpr_Update & "' "
    
End Sub

Private Sub lstOpr_Click()
    
    strOpr_Update = tString(lstOpr.SelectedItem.Text, "[", "]", 0)
    
    getLimit strOpr_Update
    lstLimited1.ListItems.Clear
    lstLimited2.ListItems.Clear
    Call getLimited1
    
End Sub

Private Sub optList_Click()
    
    If optList.Value = True Then
        optMain.Value = False
        txtName.Enabled = False
        cmbMain.Enabled = True
        txtName1.Enabled = True
        txtName1.SetFocus
        SendKeys "{Home}+{End}"
    End If
    
End Sub

Private Sub optMain_Click()
    
    If optMain.Value = True Then
        optList.Value = False
        cmbMain.Enabled = False
        txtName1.Enabled = False
        txtName.Enabled = True
    End If
    
End Sub

'显示权限
Private Sub getMain()
    
    Dim rsTemp                  As New ADODB.Recordset
    Set rsTemp = DBCN.Execute("Select * from tbCCFunction Where Len(fCode)=4 Order By fCode")
    If rsTemp.EOF = False Then
        cmbMain.Clear
        Do Until rsTemp.EOF
            cmbMain.AddItem rsTemp.Fields("fName") & "[" & rsTemp.Fields("fCode") & "]"
            rsTemp.MoveNext
        Loop
        cmbMain.Text = cmbMain.List(0)
    End If
    
End Sub

'获取后尾最大号
Private Function getMaxCode(strInfo As String) As String

    Dim rsTemp                       As New ADODB.Recordset
    Set rsTemp = DBCN.Execute("Select Max(right(fCode,4)) as Code from tbCCFunction Where Len(fCode)>4 ")
    If rsTemp.EOF = False Then
        getMaxCode = Format(Val(rsTemp.Fields("Code")) + 1, "0000")
    Else
        getMaxCode = Format(1, "0000")
    End If

End Function

Private Sub txtOpr_GotFocus(Index As Integer)
    
    txtOpr(Index).BackColor = &HC0FFC0
    txtOpr(Index).ForeColor = vbRed
    
End Sub

Private Sub txtOpr_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    
    Select Case KeyCode
        Case vbKeyDown
            If Index = txtOpr.Count - 1 Then Exit Sub
            txtOpr(Index + 1).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        Case vbKeyUp
            If Index = 0 Then Exit Sub
            txtOpr(Index - 1).SetFocus
            SendKeys "{Home}+{End}"
            Exit Sub
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub txtOpr_KeyPress(Index As Integer, KeyAscii As Integer)
    
    Select Case KeyAscii
        Case vbKeyReturn
            Select Case Index
                Case 0
                    If txtOpr(Index).Text = "" Then
                        If MsgBox("系统将自动生成最大编码？", vbInformation + vbYesNo, "提示：") = vbYes Then
                            txtOpr(Index).Text = tBigCode("tbCcOper", "Oper_id")
                            txtOpr(Index + 1).SetFocus
                            SendKeys "{Home}+{End}"
                            Exit Sub
                        Else
                            txtOpr(Index).SetFocus
                            SendKeys "{Home}+{End}"
                            Exit Sub
                        End If
                    End If
                    If tWhileCode("tbCcOper", "Oper_id", Format(Trim(txtOpr(Index).Text), "0000")) = False Then
                        MsgBox "编码重复！请检查您的输入是否正确？", vbInformation, "提示："
                        txtOpr(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    Else
                        txtOpr(Index).Text = Format(txtOpr(Index).Text, "0000")
                        txtOpr(Index + 1).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                Case 1
                    If txtOpr(Index).Text = "" Then
                        txtOpr(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    End If
                    If tWhileCode("tbCcOper", "Oper_name", Trim(txtOpr(Index).Text)) = False Then
                        MsgBox "信息重复！请检查您的输入是否正确？", vbInformation, "提示："
                        txtOpr(Index).SetFocus
                        SendKeys "{Home}+{End}"
                        Exit Sub
                    Else
                        cmdOK.SetFocus
                        Exit Sub
                    End If
            End Select
        Case Else
            Exit Sub
    End Select
    
End Sub

Private Sub txtOpr_LostFocus(Index As Integer)
    
    txtOpr(Index).BackColor = vbWhite
    txtOpr(Index).ForeColor = vbBlack
    
End Sub