frmuser.frm

中小型图书会员制租赁管理系统,采用ACCESS数据库。

      End
      Begin VB.Label lblLabels 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "密码"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   8.25
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   165
         Index           =   2
         Left            =   240
         TabIndex        =   19
         Tag             =   "&Password:"
         Top             =   960
         Width           =   360
      End
      Begin VB.Label lblLabels 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "用户名"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   8.25
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   165
         Index           =   1
         Left            =   4800
         TabIndex        =   18
         Tag             =   "&Password:"
         Top             =   360
         Width           =   540
      End
      Begin VB.Label lblLabels 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "登记日期"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   8.25
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   165
         Index           =   0
         Left            =   240
         TabIndex        =   17
         Tag             =   "&Password:"
         Top             =   360
         Width           =   720
      End
      Begin VB.Label lblLabels 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "用户ID"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   8.25
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00000000&
         Height          =   165
         Index           =   3
         Left            =   2520
         TabIndex        =   16
         Tag             =   "&Password:"
         Top             =   360
         Width           =   570
      End
   End
   Begin VB.Frame Frame2 
      Caption         =   "系统用户列表"
      Height          =   5415
      Left            =   120
      TabIndex        =   34
      Top             =   240
      Width           =   3255
   End
End
Attribute VB_Name = "frmUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Dim frmGVAR_lstUsersText As String
Private Sub cmdAddUser_Click()
If cmdAddUser.Caption = "添加用户" Then
   frmUser.Caption = "Users (Add User Mode)"
   Call cmdClear_Click
   txtDateEntered.Text = Format(Now, "mmm. d, yyyy")
   txtUserID.Text = "(AUTO-ASSIGN)"
'' Disable other controls
   cmdEdit.Enabled = False
   lstUsers.Enabled = False
''Enable update
  cmdUpdate.Enabled = True
  cmdClear.Enabled = True
   cmdAddUser.Caption = "&取消添加..."
   Call UnlockTextboxes
   txtUserName.SetFocus
   Exit Sub
End If

If cmdAddUser.Caption = "&取消添加..." Then
   frmUser.Caption = "Users"
'' Enable other controls
   cmdEdit.Enabled = True
   lstUsers.Enabled = True
   cmdAddUser.Caption = "添加用户"
   lstUsers.SetFocus
   lstUsers.Text = frmGVAR_lstUsersText
'' Enable controls
'' Disable on error
   If Trim(lstUsers.Text) = "" Then
      cmdEdit.Enabled = False
      cmdUpdate.Enabled = False
      cmdClear.Enabled = False
    Else
      cmdUpdate.Enabled = False
      cmdClear.Enabled = False
      Call LockTextboxes
   End If
   Exit Sub
End If
End Sub
Private Sub cmdClear_Click()
'' Start Clear Txt/Cbo boxes
txtUserName.Text = ""
txtPassword.Text = ""
txtConfirmPassword.Text = ""
txtAccessLevel.Text = ""
txtFirstName.Text = ""
txtMiddleName.Text = ""
txtFamilyName.Text = ""
txtSex.Text = ""
txtBirthday.Text = ""
txtContactNumber.Text = ""
txtHomeAddress.Text = ""
txtComments.Text = ""
txtUserName.SetFocus
End Sub
Private Sub cmdEdit_Click()
 If cmdEdit.Caption = "编辑" Then
    cmdEdit.Caption = "取消编辑"
    lstUsers.Enabled = False
    Call UnlockTextboxes
    cmdAddUser.Enabled = False
    cmdUpdate.Enabled = True
    cmdClear.Enabled = True
    txtUserName.SetFocus
    frmUser.Caption = "Users (Edit Mode)"
    Exit Sub
 End If
 
 If cmdEdit.Caption = "取消编辑" Then
    Call cmdClear_Click
    cmdEdit.Caption = "编辑"
    Call LockTextboxes
    cmdAddUser.Enabled = True
    lstUsers.Enabled = True
    cmdUpdate.Enabled = False
    cmdClear.Enabled = False
    lstUsers.SetFocus
    frmUser.Caption = "Users"
 lstUsers.Text = frmGVAR_lstUsersText
    Exit Sub
 End If
End Sub
Private Sub cmdRemove_Click()
    Dim vr_engine As VRENTAL_ENGINE
    Set vr_engine = New VRENTAL_ENGINE
    
    If IsNumeric(txtUserID.Text) = True And cmdEdit.Caption = "编辑" And cmdAddUser.Caption = "添加用户" Then
       If MsgBox("你确定要删除记录吗? ", vbYesNo) = vbNo Then Exit Sub
       Call vr_engine.RemoveUser(Int(txtUserID.Text))
       Call vr_engine.LoadUsers(lstUsers) ''Refresh listbox
       txtDateEntered.Text = ""
       txtUserID.Text = ""
       Call cmdClear_Click
       cmdEdit.Enabled = False
       cmdUpdate.Enabled = False
       cmdClear.Enabled = False
       If lstUsers.Enabled = True Then lstUsers.SetFocus
    Else
      '' Put Message Here
       If lstUsers.Enabled = True Then
          lstUsers.SetFocus
       Else
         txtUserName.SetFocus
       End If
    End If
End Sub
Private Sub cmdSetPermission_Click()
If gVarAccessLevel < 6 Then
    
    If lstUsers.Enabled = True Then
        lstUsers.SetFocus
    Else
        txtDateEntered.SetFocus
    End If
    Exit Sub
End If
frmPermission.Show 1
If lstUsers.Enabled = True Then
lstUsers.SetFocus
Else
txtDateEntered.SetFocus
End If
End Sub
Private Sub cmdUpdate_Click()
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE

If ValidateUserFields = 0 Then Exit Sub  '' Chk fields

If cmdAddUser.Caption = "&取消添加..." Then
    txtDateEntered.Text = Format(Now, "mmm. d, yyyy")
    txtUserID.Text = "(Auto-assign)"
    If ValidateUserFields = 0 Then Exit Sub  '' Chk fields
    If vr_engine.AddUserToDB(txtDateEntered, txtUserName, txtPassword, _
                    txtAccessLevel, txtFirstName, _
                    txtMiddleName, txtFamilyName, _
                    txtBirthday, txtSex, _
                    txtHomeAddress, txtContactNumber, _
                    txtComments) Then
    '' Do Nothing
    Else
            Exit Sub
    End If
    '' Enable other controls
        cmdEdit.Enabled = True
        lstUsers.Enabled = True
        Call vr_engine.LoadUsers(lstUsers) ''Refresh listbox
        frmGVAR_lstUsersText = Trim(txtFirstName.Text) & " " & Trim(Left(txtMiddleName.Text, 1)) & ". " & Trim(txtFamilyName.Text) & " (" & Trim(txtUserName.Text) & ")"
        lstUsers.Text = frmGVAR_lstUsersText
        lstUsers.SetFocus
        cmdAddUser.Caption = "添加用户"
    '' Disable cmdUpdate/cmdClear
       cmdUpdate.Enabled = False
       cmdClear.Enabled = False
       Exit Sub
Else
'' ========= Start Edit Update ============
If vr_engine.UpdateEditedUsersDB(txtUserName, txtPassword, _
                txtAccessLevel, txtFirstName, _
                txtMiddleName, txtFamilyName, _
                txtBirthday, txtSex, _
                txtHomeAddress, txtContactNumber, _
                txtComments, lstUsers) = True Then
'' Do Nothing
Else
  Exit Sub
End If
                
 Call vr_engine.LoadUsers(lstUsers) ''Refresh listbox
 frmGVAR_lstUsersText = Trim(txtFirstName.Text) & " " & Trim(Left(txtMiddleName.Text, 1)) & ". " & Trim(txtFamilyName.Text) & " (" & Trim(txtUserName.Text) & ")"
    '''MsgBox frmGVAR_lstUsersText
    lstUsers.Enabled = True
    cmdUpdate.Enabled = False
    lstUsers.SetFocus
    MsgBox "记录已更新。", vbOKOnly, "成功更新！"
    Call LockTextboxes
    cmdEdit.Caption = "编辑"
    frmUser.Caption = "Users"
    cmdUpdate.Enabled = False
    cmdClear.Enabled = False
    cmdAddUser.Enabled = True
    txtDateEntered.Locked = True
    lstUsers.Text = frmGVAR_lstUsersText
'' ========= End Edit Update ============
End If
End Sub
Private Sub Form_Load()
  lstUsers.Clear '' Clears listbox
  Dim vr_engine As VRENTAL_ENGINE
  Set vr_engine = New VRENTAL_ENGINE
  Call vr_engine.LoadUsers(lstUsers)
End Sub
Private Sub lstUsers_Click()
Dim vr_engine As VRENTAL_ENGINE
Set vr_engine = New VRENTAL_ENGINE
    
Call vr_engine.getUserInfo(txtUserID, txtDateEntered, _
                txtUserName, txtPassword, _
                txtAccessLevel, txtFirstName, _
                txtMiddleName, txtFamilyName, _
                txtBirthday, txtSex, _
                txtHomeAddress, txtContactNumber, _
                txtComments, txtConfirmPassword, lstUsers)
cmdEdit.Enabled = True
frmGVAR_lstUsersText = lstUsers.Text
End Sub
Sub UnlockTextboxes()
    'txtDateEntered.Locked = False
    txtUserName.Locked = False
    txtPassword.Locked = False
    txtConfirmPassword.Locked = False
    txtAccessLevel.Locked = False
    txtFirstName.Locked = False
    txtMiddleName.Locked = False
    txtFamilyName.Locked = False
    txtSex.Locked = False
    txtBirthday.Locked = False
    txtContactNumber.Locked = False
    txtHomeAddress.Locked = False
    txtComments.Locked = False
End Sub
Sub LockTextboxes()
    txtUserName.Locked = True
    txtPassword.Locked = True
    txtConfirmPassword.Locked = True
    txtAccessLevel.Locked = True
    txtFirstName.Locked = True
    txtMiddleName.Locked = True
    txtFamilyName.Locked = True
    txtSex.Locked = True
    txtBirthday.Locked = True
    txtContactNumber.Locked = True
    txtHomeAddress.Locked = True
    txtComments.Locked = True
End Sub
Function ValidateUserFields()     '检查所输入数据是否合法！
    If IsDate(txtDateEntered.Text) Then
        txtDateEntered.Text = Format(txtDateEntered.Text, "mmm. d, yyyy")
    Else
        MsgBox "非法数据！ ", vbCritical, "发生错误"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If Trim(txtUserName.Text = "") Then
        MsgBox "非法用户名", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If Trim(txtPassword.Text) <> Trim(txtConfirmPassword.Text) Then
        MsgBox "新密码与确认密码不符！ ", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If txtPassword.Text = "" Then
        MsgBox "你必须输入一个密码", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If IsNumeric(Trim(txtAccessLevel.Text)) Then
        txtAccessLevel.Text = Int(Trim(txtAccessLevel.Text))
    Else
        MsgBox "抱歉，非法权限", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If

    
    If Trim(txtFirstName.Text) = "" Then
        MsgBox "名字1为空！", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If Trim(txtMiddleName.Text) = "" Then
        MsgBox "名字2为空！ ", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If

    If Trim(txtFamilyName.Text) = "" Then
        MsgBox "你没有姓吗？！", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If Trim(txtMiddleName.Text) = "" Then
        MsgBox "名字2为空！ ", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
    
    If IsDate(txtBirthday.Text) Then
        txtBirthday.Text = Format(txtBirthday.Text, "mmm. d, yyyy")
    Else
        MsgBox "生日数据非法！", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If


    If Trim(txtSex.Text) <> "男" And Trim(txtSex.Text) <> "女" _
       And UCase(Trim(txtSex.Text)) <> "M" And UCase(Trim(txtSex.Text)) <> "F" Then
        'MsgBox txtSex.Text
        MsgBox "请输入性别项！", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    Else
           If Left(txtSex.Text, 1) = "M" Then txtSex.Text = "男"
           If Left(txtSex.Text, 1) = "F" Then txtSex.Text = "女"
    End If
    
    If Trim(txtHomeAddress.Text = "") Then
        MsgBox "请输入你的地址", vbCritical, "Error"
        ValidateUserFields = 0
        Exit Function
    End If
        ValidateUserFields = 1
End Function
Private Sub txtAccessLevel_LostFocus()
If Val(txtAccessLevel.Text) > 6 Then
    MsgBox "'权限不能超过6级！ ", vbInformation, "Invalid Entry"
    txtAccessLevel.Text = ""
    txtAccessLevel.SetFocus
    Exit Sub
End If
If Val(txtAccessLevel.Text) > gVarAccessLevel Then
   MsgBox "'通道权限' 不能比你自身的权限水平高！ ", vbInformation, "非法输入！"
    txtAccessLevel.Text = ""
    txtAccessLevel.SetFocus
    Exit Sub
End If
End Sub