📄 frmuser.frm
字号:
Caption = "User Name"
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 161
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 210
Index = 1
Left = 4800
TabIndex = 18
Tag = "&Password:"
Top = 360
Width = 795
End
Begin VB.Label lblLabels
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Date Entered"
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 161
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 210
Index = 0
Left = 240
TabIndex = 17
Tag = "&Password:"
Top = 360
Width = 930
End
Begin VB.Label lblLabels
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "User ID"
BeginProperty Font
Name = "Arial"
Size = 8.25
Charset = 161
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 210
Index = 3
Left = 2520
TabIndex = 16
Tag = "&Password:"
Top = 360
Width = 645
End
End
Begin VB.Frame Frame2
Caption = " Users "
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 = "&Add User" 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
'' Disable controls
''Enable update
cmdUpdate.Enabled = True
cmdClear.Enabled = True
''
cmdAddUser.Caption = "&Cancel Add..."
Call UnlockTextboxes
txtUserName.SetFocus
Exit Sub
End If
''-------------------------------------------
''-------------------------------------------
If cmdAddUser.Caption = "&Cancel Add..." Then
frmUser.Caption = "Users"
'' Enable other controls
cmdEdit.Enabled = True
lstUsers.Enabled = True
cmdAddUser.Caption = "&Add User"
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 = "&Edit" Then
cmdEdit.Caption = "&Cancel Edit"
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 = "&Cancel Edit" Then
Call cmdClear_Click
cmdEdit.Caption = "&Edit"
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 = "&Edit" _
And cmdAddUser.Caption = "&Add User" Then
If MsgBox("Are you sure you want to delete this user? ", 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 = "&Cancel Add..." 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 = "&Add User"
'' Enable controls
'' Disable cmdUpdate/cmdClear
cmdUpdate.Enabled = False
cmdClear.Enabled = False
Exit Sub
Else
'' ========= Start Edit Update ============
'' ========= 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 "Record has been successfully updated. ", vbOKOnly, "Success"
Call LockTextboxes
cmdEdit.Caption = "&Edit"
frmUser.Caption = "Users"
cmdUpdate.Enabled = False
cmdClear.Enabled = False
cmdAddUser.Enabled = True
txtDateEntered.Locked = True
lstUsers.Text = frmGVAR_lstUsersText
'' ========= End Edit Update ============
'' ========= 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 "Invalid Date. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If Trim(txtUserName.Text = "") Then
MsgBox "Invalid User Name. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If Trim(txtPassword.Text) <> Trim(txtConfirmPassword.Text) Then
MsgBox "Mismatch between Password and Confirm Password. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If txtPassword.Text = "" Then
MsgBox "You must have a password. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If IsNumeric(Trim(txtAccessLevel.Text)) Then
txtAccessLevel.Text = Int(Trim(txtAccessLevel.Text))
Else
MsgBox "Invalid Access Level. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If Trim(txtFirstName.Text) = "" Then
MsgBox "First Name field is empty.", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If Trim(txtMiddleName.Text) = "" Then
MsgBox "Middle Name field is empty. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If Trim(txtFamilyName.Text) = "" Then
MsgBox "Family Name field is empty. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If Trim(txtMiddleName.Text) = "" Then
MsgBox "Middle Name field is empty. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If IsDate(txtBirthday.Text) Then
txtBirthday.Text = Format(txtBirthday.Text, "mmm. d, yyyy")
Else
MsgBox "Invalid Birth Date. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
If UCase(Trim(txtSex.Text)) <> "MALE" And UCase(Trim(txtSex.Text)) <> "FEMALE" _
And UCase(Trim(txtSex.Text)) <> "M" And UCase(Trim(txtSex.Text)) <> "F" Then
'MsgBox txtSex.Text
MsgBox "Undetermined Sex!!! ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
Else
If UCase(Left(txtSex.Text, 1)) = "M" Then txtSex.Text = "Male"
If UCase(Left(txtSex.Text, 1)) = "F" Then txtSex.Text = "Female"
End If
If Trim(txtHomeAddress.Text = "") Then
MsgBox "Enter your address. ", vbCritical, "Error"
ValidateUserFields = 0
Exit Function
End If
ValidateUserFields = 1
End Function
Private Sub txtAccessLevel_LostFocus()
If Val(txtAccessLevel.Text) > 6 Then
MsgBox "'Access Level' should not be greater than 6. ", vbInformation, "Invalid Entry"
txtAccessLevel.Text = ""
txtAccessLevel.SetFocus
Exit Sub
End If
If Val(txtAccessLevel.Text) > gVarAccessLevel Then
MsgBox "'Access Level' should not be greater than your own access level. ", vbInformation, "Invalid Entry"
txtAccessLevel.Text = ""
txtAccessLevel.SetFocus
Exit Sub
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -