frmuser.frm

本论文以西电基础教学实验中心学生上机管理系统为背景

            fraPurview.Enabled = False
            cmdEdit.Caption = "修 改"
            cbpType.Enabled = True
            lvwUser.Enabled = True
            Else
            Exit Sub
        End If
End If
End Sub

Private Sub cmdLeft_Click()
If litSelected.ListIndex <> -1 Then
    litSelected.RemoveItem litSelected.ListIndex
End If
End Sub
Private Sub cmdLeftAll_Click()
ClearItem
End Sub

Private Sub cmdRight_Click()
If litSelect.ListIndex <> -1 Then
    litSelected.AddItem litSelect.List(litSelect.ListIndex)
End If
End Sub

Private Sub cmdRightAll_Click()
Dim i As Integer
For i = (litSelect.ListCount - 1) To 0 Step -1
    litSelected.AddItem litSelect.List(i)
Next
End Sub
Private Sub Form_Load()
EdotJudge = "false"
AddJudge = "false"
 fraUaer.Enabled = False
 fraPurview.Enabled = False
 
'******************************************给可供选择的权限列表赋值**********************
 Set rsPurview = New Recordset
 rsPurview.Open "select * from tbpurview", Modmain.conn, 3, 2
 While Not rsPurview.EOF
     litSelect.AddItem rsPurview.Fields!P_Name
 rsPurview.MoveNext
 Wend
 rsPurview.Close
 Set rsPurview = Nothing
 
'******************************************配置lvwUser控件并赋值**********************
lvwUser.ColumnHeaders.Add , , "", 1850
lvwUser.Sorted = True
lvwUser.View = lvwReport

Set rsUser = New Recordset
rsUser.Open "select * from TbUser", Modmain.conn, 3, 2
    While Not rsUser.EOF              ' 添加相应的 ListItem
      Set lItem = lvwUser.ListItems.Add
      lItem.Text = rsUser.Fields("U_Name")
      rsUser.MoveNext
    Wend
rsUser.Close
Set rsUser = Nothing
End Sub
Private Sub lvwUser_ItemClick(ByVal Item As MSComctlLib.ListItem)
StrItem = Item                            '记录该用户的用户名
Intindex = Item.Index
'***********************************查找该操作员的ID并填写相关信息*********************************
Set rsUser = New Recordset
rsUser.Open "select * from TbUser where U_Name like '" & Item & "'", Modmain.conn, 3, 2
txtU_Name.Text = rsUser.Fields!u_name
txtPsd.Text = rsUser.Fields!U_Psw
Password.Text = rsUser.Fields!U_Psw
StrU_ID = rsUser.Fields!U_ID                '记录该用户的用户ID
rsUser.Close
Set rsUser = Nothing

'**********************************查找该用户的角色并填写**********************************
Set rsRole = New Recordset
rsRole.Open "select * from TbRole where R_ID = '" & Left(StrU_ID, 1) & "'", Modmain.conn, 3, 2
cbpType.Text = rsRole.Fields!r_Name
rsRole.Close
Set rsRole = Nothing

'**********************************查找并填写该用户的权限***********************************
Set rsPurview = New Recordset
rsPurview.Open "select TbPurview.P_Name from TbPurview,TbAllocatee where TbAllocatee.P_ID=TbPurview.P_ID and tbAllocatee.U_ID LIKE '" & StrU_ID & "'", Modmain.conn, 3, 2
ClearItem
While Not rsPurview.EOF
     litSelected.AddItem rsPurview.Fields!P_Name
    rsPurview.MoveNext
Wend
rsPurview.Close
Set rsPurview = Nothing
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''清空已选择的用户权限                                                                      ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub ClearItem()
Dim i As Integer
For i = (litSelected.ListCount - 1) To 0 Step -1
    litSelected.RemoveItem (i)
Next
End Sub

Private Sub txtPsd_LostFocus()
If cmdAdd.Caption = "保 存" Then
    Set rsUser = New Recordset
    rsUser.Open "select * from TbUser where U_Psw like '" & txtPsd.Text & "'", Modmain.conn, 3, 2
    
    If rsUser.RecordCount <> 0 Then
        MsgBox "该密码已经有人使用，请重新编写！", vbOKOnly + vbCritical, "机房管理"
        txtPsd.Text = ""
        txtPsd.SetFocus
    End If
    rsUser.Close
    Set rsUser = Nothing
End If
End Sub

Private Sub txtU_Name_LostFocus()
If cmdAdd.Caption = "保 存" Then
    Set rsUser = New Recordset
    rsUser.Open "select * from TbUser where u_name like '" & txtU_Name.Text & "'", Modmain.conn, 3, 2
    
    If rsUser.RecordCount <> 0 Then
        MsgBox "用户名已存在，请重新编写！", vbOKOnly + vbCritical, "机房管理"
        txtU_Name.Text = ""
        txtU_Name.SetFocus
    End If
    rsUser.Close
    Set rsUser = Nothing
End If
End Sub
Private Sub AddNewUser()
If Judge = True Then
    If MsgBox("确实要保存吗?", vbYesNo + vbQuestion, "机房管理") = vbYes Then
        SaveInfo
        Set lItem = lvwUser.ListItems.Add
        lItem.Text = txtU_Name.Text
        MsgBox "保存成功", vbOKOnly + vbInformation, "机房管理"    '保存完毕并提醒
        AddJudge = "true"
    End If
End If
End Sub
Private Function Judge() As Boolean
If txtPsd.Text <> Password.Text Then
    MsgBox "确认密码不一致请重新填写！", vbOKOnly + vbExclamation, "机房管理"
    Password.Text = ""
    Password.SetFocus
    ElseIf txtU_Name.Text = "" Then
        MsgBox "用户名不能为空！", vbOKOnly + vbExclamation, "机房管理"
        txtU_Name.SetFocus
        ElseIf txtPsd.Text = "" Then
            MsgBox "密码不能为空！", vbOKOnly + vbExclamation, "机房管理"
            txtPsd.SetFocus
            ElseIf cbpType.Text = "超级用户" And cmdAdd.Caption = "保 存" Then
                MsgBox "本系统只能有一个超级用户，请重新选择！", vbOKOnly + vbExclamation, "机房管理"
                cbpType.ListIndex = -1
   Else
        Judge = True
End If
End Function
Private Sub SaveInfo()
'**************************************产生该用户的ID********************************
Dim rsMaxNo As Recordset
Set rsMaxNo = New Recordset
rsMaxNo.Open "select max(right(u_id,2)) as MaxNo  from TbUser,tbrole where left(TbUser.u_id,1)=tbrole.R_ID and  tbrole.r_name like '" & cbpType.Text & "'", Modmain.conn, 3, 2
Dim STRID As String
STRID = strR_ID & Right("0" & CStr(CInt(rsMaxNo.Fields!maxno) + 1), 2)
rsMaxNo.Close
Set rsMaxNo = Nothing
'**************************************保存该用户的信息*****************************
Set rsUser = New Recordset
rsUser.Open "select * from TbUser", Modmain.conn, 3, 2
rsUser.AddNew
rsUser.Fields!U_ID = STRID
rsUser.Fields!u_name = txtU_Name.Text
rsUser.Fields!U_Psw = txtPsd.Text
rsUser.Update
'*************************************保存该用户的权限*****************************

Dim i As Integer
For i = (litSelected.ListCount - 1) To 0 Step -1
    Dim strMemo As String
    strMemo = litSelected.List(i)
     Set rsPurview = New Recordset
     rsPurview.Open "select * from tbpurview where P_Name like '" & strMemo & "'", Modmain.conn, 3, 2
     
     Set rsAllocatee = New Recordset
     rsAllocatee.Open "select * from tbAllocatee ", Modmain.conn, 3, 2
     rsAllocatee.AddNew
        rsAllocatee.Fields!U_ID = STRID
        rsAllocatee.Fields!p_id = rsPurview.Fields!p_id
    rsAllocatee.Update
    rsPurview.Close
    Set rsPurview = Nothing
    rsAllocatee.Close
    Set rsAllocatee = Nothing
Next
    Call AddLog("L28", "Add")        '操作日志
End Sub

Private Sub DeleteUser()
If MsgBox("确实要删除吗?", vbYesNo + vbQuestion, "机房管理") = vbYes Then
    '*************************************** 删除该用户的信息******************
    Set rsUser = New Recordset
    rsUser.Open "select * from TbUser where u_id like '" & StrU_ID & "'", Modmain.conn, 3, 2
    rsUser.Delete
    rsUser.Close
    Set rsUser = Nothing
    '**************************************删除该用户的权限信息******************
    Set rsAllocatee = New Recordset
    rsAllocatee.Open "select * from tbAllocatee where u_id like '" & StrU_ID & "'", Modmain.conn, 3, 2
    While Not rsAllocatee.EOF
        rsAllocatee.Delete
        rsAllocatee.MoveNext
    Wend
    rsAllocatee.Close
    Set rsAllocatee = Nothing
    lvwUser.ListItems.Remove (Intindex)           '删除用户列表框的信息
    ClearInfo
    ClearItem
    Call AddLog("L29", "Delete")
    MsgBox "删除成功", vbOKOnly + vbInformation, "机房管理"    '保存完毕并提醒

End If
End Sub

Private Sub ClearInfo()
cbpType.ListIndex = -1
txtU_Name.Text = ""
txtPsd.Text = ""
Password.Text = ""
End Sub

Private Sub AddEditInfo()
If Judge = True Then
    If MsgBox("确实要保存吗?", vbYesNo + vbQuestion, "机房管理") = vbYes Then
        '**************************************保存该用户的信息*****************************
        Set rsUser = New Recordset
        rsUser.Open "select * from TbUser where u_name like '" & StrItem & "'", Modmain.conn, 3, 2
        rsUser.Fields!u_name = txtU_Name.Text
        rsUser.Fields!U_Psw = txtPsd.Text
        rsUser.Update
        Set itmX = lvwUser.FindItem(StrItem, , , lvwPartial) '改变lvwPweson控件的金额值
        itmX.Text = txtU_Name.Text
        
        '**************************************首先删除该用户的权限信息******************
        Set rsAllocatee = New Recordset
        rsAllocatee.Open "select * from tbAllocatee where u_id like '" & StrU_ID & "'", Modmain.conn, 3, 2
        While Not rsAllocatee.EOF
            rsAllocatee.Delete
            rsAllocatee.MoveNext
        Wend
        rsAllocatee.Close
        Set rsAllocatee = Nothing
      '*************************************重新保存该用户的权限信息*****************************
    
        Dim i As Integer
        For i = (litSelected.ListCount - 1) To 0 Step -1
            Dim strMemo As String
            strMemo = litSelected.List(i)
            Set rsPurview = New Recordset
            rsPurview.Open "select * from tbpurview where P_Name like '" & strMemo & "'", Modmain.conn, 3, 2
             
            Set rsAllocatee = New Recordset
            rsAllocatee.Open "select * from tbAllocatee ", Modmain.conn, 3, 2
            rsAllocatee.AddNew
            rsAllocatee.Fields!U_ID = StrU_ID
            rsAllocatee.Fields!p_id = rsPurview.Fields!p_id
            rsAllocatee.Update
            rsPurview.Close
            Set rsPurview = Nothing
            rsAllocatee.Close
            Set rsAllocatee = Nothing
        Next
        MsgBox "修改成功", vbOKOnly + vbInformation, "机房管理"    '保存完毕并提醒
        EdotJudge = "true"
  Call AddLog("L27", "Edit")
    End If
End If
End Sub
Private Sub litSelect_DragDrop(Source As Control, X As Single, Y As Single)
If frmUser.ActiveControl.Name = "litSelected" Then           '在文件列表中drag并drop不执行此段代码，即在本列表中拖放不执行任何操作
    litSelected.RemoveItem litSelected.ListIndex                  '将临时文件列表中的文件移入文件列表
End If
End Sub
Private Sub litSelected_DragDrop(Source As Control, X As Single, Y As Single)
If frmUser.ActiveControl.Name = "litSelect" Then              '在临时文件列表中drag并drop不执行此段代码，即在本列表中拖放不执行任何操作
    litSelected.AddItem litSelect.List(litSelect.ListIndex)        '将文件列表中的文件移入临时文件列表
End If
End Sub
Private Sub litSelect_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
temp_lab.Move litSelect.Left, litSelect.Top + Y, temp_lab.Width, temp_lab.Height        '实际是移动标签
temp_lab.Drag                                                                   '启动标签的拖放操作
End Sub
Private Sub litSelected_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
temp_lab.Move litSelected.Left, litSelected.Top + Y, temp_lab.Width, temp_lab.Height           '实际是移动标签
If litSelected.ListCount > 0 Then                      '当列表框为空时不进行拖放操作
    temp_lab.Drag                                  '启动标签的拖放操作
End If
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''将用户添加、修改、删除操作员的信息记入操作日志                        ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub AddLog(LogType As String, cc As String)
Dim strEvents As String
Dim strTemp As String
strTemp = "'"
Set rsOperateLog = New Recordset
rsOperateLog.Open "select * from tbOperateLog", Modmain.conn, 3, 2
Set rsLog = New Recordset
rsLog.Open "select * from tblog where L_ID='" & LogType & "'", Modmain.conn, 3, 2
strEvents = rsLog.Fields!Events

rsOperateLog.AddNew
    rsOperateLog.Fields!U_ID = frmLoad.StrU_ID
    rsOperateLog.Fields!Time = Time
    rsOperateLog.Fields!Date = Date
    rsOperateLog.Fields!Events = strEvents
    If cc = "Delete" Then
        rsOperateLog.Fields!Description = strEvents & strTemp & StrItem & strTemp
    Else
        rsOperateLog.Fields!Description = strEvents & strTemp & txtU_Name.Text & strTemp
    End If
rsOperateLog.Update
End Sub