frmusersetup.frm

我就不做什么介绍了.你们打家假如要管理系统的话就下下来自己看吧

VERSION 5.00
Begin VB.Form frmUserSetup 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "用户设置"
   ClientHeight    =   3480
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5670
   Icon            =   "frmUserSetup.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   3480
   ScaleWidth      =   5670
   Begin VB.CommandButton cmdClose 
      Caption         =   "关闭"
      Height          =   375
      Left            =   4080
      TabIndex        =   13
      Top             =   2760
      Width           =   1095
   End
   Begin VB.CommandButton cmdChangePassword 
      Caption         =   "更改密码"
      Height          =   375
      Left            =   2760
      TabIndex        =   12
      Top             =   2760
      Width           =   1095
   End
   Begin VB.TextBox txtOldPassword 
      Height          =   285
      IMEMode         =   3  'DISABLE
      Left            =   3600
      PasswordChar    =   "*"
      TabIndex        =   4
      Top             =   1320
      Visible         =   0   'False
      Width           =   1935
   End
   Begin VB.TextBox txtReenter 
      Height          =   285
      IMEMode         =   3  'DISABLE
      Left            =   3600
      PasswordChar    =   "*"
      TabIndex        =   3
      Top             =   960
      Visible         =   0   'False
      Width           =   1935
   End
   Begin VB.CommandButton cmdDeleteUser 
      Caption         =   "删除用户"
      Height          =   375
      Left            =   4080
      TabIndex        =   6
      Top             =   2280
      Width           =   1095
   End
   Begin VB.CommandButton cmdAddUser 
      Caption         =   "新用户"
      Height          =   375
      Left            =   2760
      TabIndex        =   5
      Top             =   2280
      Width           =   1095
   End
   Begin VB.TextBox txtPassword 
      Height          =   285
      IMEMode         =   3  'DISABLE
      Left            =   3600
      PasswordChar    =   "*"
      TabIndex        =   2
      Top             =   600
      Width           =   1935
   End
   Begin VB.TextBox txtUserName 
      Height          =   285
      Left            =   3600
      TabIndex        =   1
      ToolTipText     =   "Enter User Name"
      Top             =   240
      Width           =   1935
   End
   Begin VB.PictureBox lstUsers 
      BackColor       =   &H00E0E0E0&
      ForeColor       =   &H80000008&
      Height          =   3015
      Left            =   120
      ScaleHeight     =   2955
      ScaleWidth      =   2070
      TabIndex        =   0
      Top             =   240
      Width           =   2130
   End
   Begin VB.Label lblNewPassword 
      Caption         =   "新密码 :"
      Height          =   255
      Left            =   2400
      TabIndex        =   11
      Top             =   1680
      Visible         =   0   'False
      Width           =   975
   End
   Begin VB.Label lblOldPassword 
      Caption         =   "旧密码 :"
      Height          =   255
      Left            =   2400
      TabIndex        =   10
      Top             =   1320
      Visible         =   0   'False
      Width           =   975
   End
   Begin VB.Label lblReenter 
      Caption         =   "重输密码 :"
      Height          =   255
      Left            =   2400
      TabIndex        =   9
      Top             =   960
      Visible         =   0   'False
      Width           =   975
   End
   Begin VB.Label lblPassword 
      Caption         =   "密码 :"
      Height          =   255
      Left            =   2400
      TabIndex        =   8
      Top             =   600
      Width           =   975
   End
   Begin VB.Label Label1 
      Caption         =   "用户名 :"
      Height          =   255
      Left            =   2400
      TabIndex        =   7
      Top             =   240
      Width           =   975
   End
End
Attribute VB_Name = "frmUserSetup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim LUsersRs As ADODB.Recordset
Dim UserRs As ADODB.Recordset
Dim OldPassword As String
Private mclsMidTier As clsMidTier

Private Sub cmdAddUser_Click()
Dim UserXRs As ADODB.Recordset
    'If Not CusRS.State = adStateClosed Then CusRS.Close
If cmdAddUser.Caption = "新用户" Then
    lblReenter.Visible = True
    txtReenter.Visible = True
    Set UserRs = mclsMidTier.GetList("SELECT * FROM UserInfo")
    Set txtUserName.DataSource = UserRs
    txtUserName.DataField = "UserName"
    Set txtPassword.DataSource = UserRs
    txtPassword.DataField = "UserPassword"
    UserRs.AddNew
    txtUserName.SetFocus
    cmdAddUser.Caption = "保存用户"
ElseIf cmdAddUser.Caption = "保存用户" Then
'      On Error GoTo errFucks
    If txtUserName.Text = Empty Or txtPassword.Text = Empty Then
        MsgBox "你必须输入用户名或密码！", vbCritical
        If txtUserName.Text = Empty Then txtUserName.SetFocus
        If txtUserName.Text <> Empty And txtPassword.Text = Empty Then txtPassword.SetFocus
        Exit Sub
    End If
    Set UserXRs = mclsMidTier.GetList("SELECT * FROM UserInfo", "UserName = '" & txtUserName.Text & "'")
   If UserXRs.RecordCount = 0 Then
    If txtPassword.Text = txtReenter.Text Then
      UserRs.Update
      UserRs.Close
      cmdAddUser.Caption = "新用户"
      lblReenter.Visible = False
      txtReenter.Visible = False
      txtReenter.Text = ""
      Set UserRs = mclsMidTier.GetList("SELECT * FROM UserInfo")
      Set txtUserName.DataSource = UserRs
      txtUserName.DataField = "UserName"
      Set txtPassword.DataSource = UserRs
      txtPassword.DataField = "UserPassword"
      DoList
      Exit Sub
    ElseIf txtPassword.Text <> txtReenter.Text Then
      MsgBox "Passwords does not match, Try Again", vbCritical
      txtPassword.Text = ""
      txtReenter.Text = ""
      txtPassword.SetFocus
    End If
   ElseIf UserXRs.RecordCount <> 0 Then
     MsgBox "你输入的用户名已存在，请另输一个！", vbCritical
     txtUserName.Text = ""
     txtPassword.Text = ""
     txtReenter.Text = ""
     txtUserName.SetFocus
   End If 'userxrs.recordcount
'errFucks:
'    MsgBox "oops! Unexpacted Error, contact vendor."
End If
End Sub

Private Sub cmdChangePassword_Click()
    Dim UserCRS As ADODB.Recordset
    
    If cmdChangePassword.Caption = "更改密码" Then
        cmdChangePassword.Caption = "保存新密码"
        ChangePos
        OldPassword = txtPassword.Text
        txtOldPassword.SetFocus
        txtPassword.Text = ""
    ElseIf cmdChangePassword.Caption = "保存新密码" Then
     If txtPassword.Text = txtReenter.Text And txtPassword <> "" Then
      cmdChangePassword.Caption = "更改密码"
      
      UserRs.Update
      UserRs.Close
      StartPos
        txtOldPassword.Text = ""
        txtReenter.Text = ""
        Set UserRs = mclsMidTier.GetList("SELECT * FROM UserInfo")
        Set txtUserName.DataSource = UserRs
        txtUserName.DataField = "UserName"
        Set txtPassword.DataSource = UserRs
        txtPassword.DataField = "UserPassword"
        
        DoList
     ElseIf txtPassword.Text <> txtReenter.Text Or txtPassword = "" Then
        MsgBox "密码不匹配或为空！", , "密码错误"
        txtPassword.SetFocus
     End If
    End If
End Sub

Private Sub cmdClose_Click()
   Unload Me
End Sub

Private Sub cmdDeleteUser_Click()
    Dim Response As Integer
    If Not UserRs.EOF Or UserRs.BOF Then
        Response = MsgBox("删除用户，你确定吗?", vbQuestion + vbYesNo, "提示")
        If Response = vbYes Then
         UserRs.Delete
         txtUserName.Text = ""
         txtPassword.Text = ""
         txtReenter.Text = ""
        ElseIf Response = vbNo Then
        
        End If
    End If
      Set UserRs = mclsMidTier.GetList("SELECT * FROM UserInfo")
      Set txtUserName.DataSource = UserRs
      txtUserName.DataField = "UserName"
      Set txtPassword.DataSource = UserRs
      txtPassword.DataField = "UserPassword"
     DoList
End Sub

Private Sub Form_Load()
    Set mclsMidTier = New clsMidTier
    Set UserRs = mclsMidTier.GetList("select * from userinfo")
    Set txtUserName.DataSource = UserRs
    txtUserName.DataField = "UserName"
    Set txtPassword.DataSource = UserRs
    txtPassword.DataField = "UserPassword"
    DoList
End Sub
Private Sub DoList()

    Set LUsersRs = mclsMidTier.GetList("Select UserName from UserInfo")
    lstUsers.ListItems.Clear
    If Not LUsersRs.BOF Then LUsersRs.MoveFirst
    Do While Not LUsersRs.EOF
        lstUsers.ListItems.Add , , LUsersRs("UserName")
        LUsersRs.MoveNext
    Loop
    If LUsersRs.RecordCount = 0 Then
       cmdDeleteUser.Enabled = False
       cmdChangePassword.Enabled = False
    ElseIf LUsersRs.RecordCount <> 0 Then
       cmdDeleteUser.Enabled = True
       cmdChangePassword.Enabled = True
    End If
    lstUsers.Refresh
End Sub
Private Sub lstUsers_Click()
  FromListUpdate
End Sub

Private Sub FromListUpdate()
    On Error GoTo ExiThis
    If Not UserRs.BOF Then UserRs.MoveFirst
    If Not lstUsers.SelectedItem.Text = Empty Then
        UserRs.Find "UserName='" & Trim(lstUsers.SelectedItem.Text) & "'"
    End If
ExiThis:
End Sub

Private Sub txtOldPassword_LostFocus()
If OldPassword <> txtOldPassword.Text Then
  MsgBox "密码不正确！", , "密码错误"
  txtOldPassword.SetFocus
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
   Set mclsMidTier = Nothing
   LUsersRs.Close
   UserRs.Close
   Set LUsersRs = Nothing
   Set UserRs = Nothing
End Sub

Private Sub StartPos()
    cmdAddUser.Enabled = True
    cmdDeleteUser.Enabled = True
    lstUsers.TabIndex = 0
    txtUserName.TabIndex = 1
    txtPassword.TabIndex = 2
    txtReenter.TabIndex = 3
    txtOldPassword.TabIndex = 4
    cmdAddUser.TabIndex = 6
    cmdDeleteUser.TabIndex = 7
    cmdChangePassword.TabIndex = 8
    lblPassword.Top = 600
    txtPassword.Top = 600
    lblReenter.Top = 960
    txtReenter.Top = 960
    lblOldPassword.Top = 1320
    txtOldPassword = 1320
    lblNewPassword.Top = 1680
    lstUsers.Enabled = True
    txtUserName.Enabled = True
    lblPassword.Visible = True
    txtPassword.Visible = True
    lblNewPassword.Visible = False
    lblReenter.Visible = False
    txtReenter.Visible = False
    lblOldPassword.Visible = False
    txtOldPassword.Visible = False
End Sub

Private Sub ChangePos()
    cmdAddUser.Enabled = False
    cmdDeleteUser.Enabled = False
    lblPassword.Visible = False
    txtPassword.Visible = True
    txtPassword.Top = 960
    lblNewPassword.Top = 960
    lblReenter.Top = 1320
    txtReenter.Top = 1320
    lblOldPassword.Top = 600
    txtOldPassword.Top = 600
    txtOldPassword.TabIndex = 1
    txtPassword.TabIndex = 2
    txtReenter.TabIndex = 3
    lstUsers.Enabled = False
    txtUserName.Enabled = False
    lblNewPassword.Visible = True
    lblReenter.Visible = True
    txtReenter.Visible = True
    lblOldPassword.Visible = True
    txtOldPassword.Visible = True
End Sub