📄 frmaccounts.frm
字号:
VERSION 5.00
Begin VB.Form frmAccounts
AutoRedraw = -1 'True
BorderStyle = 0 'None
Caption = "System Accounts"
ClientHeight = 4770
ClientLeft = 420
ClientTop = 0
ClientWidth = 8745
LockControls = -1 'True
MaxButton = 0 'False
MDIChild = -1 'True
MinButton = 0 'False
Picture = "frmAccounts.frx":0000
ScaleHeight = 4770
ScaleWidth = 8745
ShowInTaskbar = 0 'False
Begin VB.CheckBox chkUserSecurity
Height = 195
Left = 4260
TabIndex = 16
Top = 2760
Visible = 0 'False
Width = 195
End
Begin VB.TextBox txtLastLogin
Height = 285
Left = 4260
Locked = -1 'True
TabIndex = 14
ToolTipText = "Users Last Login"
Top = 2340
Width = 2445
End
Begin VB.TextBox txtPassWord
Height = 285
Left = 4260
TabIndex = 3
ToolTipText = "Users Password"
Top = 1920
Width = 2445
End
Begin VB.TextBox txtFullName
Height = 285
Left = 4260
TabIndex = 2
ToolTipText = "Users Full Name"
Top = 1500
Width = 2445
End
Begin VB.TextBox txtLoginName
Height = 285
Left = 4260
TabIndex = 1
ToolTipText = "Users Login Name"
Top = 1080
Width = 2445
End
Begin VB.ListBox lstUsers
Height = 1620
ItemData = "frmAccounts.frx":62BC2
Left = 300
List = "frmAccounts.frx":62BC4
TabIndex = 0
Top = 1020
Width = 2565
End
Begin VB.Timer Timer1
Interval = 500
Left = 7230
Top = 840
End
Begin VB.Label lblUserSecurity
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Admin Access"
ForeColor = &H00FFFFC0&
Height = 195
Left = 3150
TabIndex = 17
Tag = "Label"
Top = 2760
Visible = 0 'False
Width = 1005
End
Begin VB.Label lblLastlogin
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Last Login"
ForeColor = &H00FFFFC0&
Height = 195
Index = 3
Left = 3150
TabIndex = 15
Tag = "Label"
Top = 2370
Width = 735
End
Begin VB.Label lblHelp
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Help..."
ForeColor = &H00C0FFC0&
Height = 195
Left = 4890
TabIndex = 13
Tag = "ButtonLabel"
Top = 3360
Width = 495
End
Begin VB.Label lblDelete
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Delete"
ForeColor = &H00C0FFC0&
Height = 195
Left = 2610
TabIndex = 12
Tag = "ButtonLabel"
Top = 3360
Width = 495
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Password"
ForeColor = &H00FFFFC0&
Height = 195
Index = 2
Left = 3150
TabIndex = 11
Tag = "Label"
Top = 1950
Width = 705
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Full Name"
ForeColor = &H00FFFFC0&
Height = 195
Index = 1
Left = 3150
TabIndex = 10
Tag = "Label"
Top = 1530
Width = 705
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Login Name"
ForeColor = &H00FFFFC0&
Height = 195
Index = 0
Left = 3150
TabIndex = 9
Tag = "Label"
Top = 1110
Width = 855
End
Begin VB.Label lblUsers
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Users"
ForeColor = &H00FFFFC0&
Height = 195
Left = 330
TabIndex = 8
Tag = "Label"
Top = 750
Width = 405
End
Begin VB.Label lblSystemAccounts
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Edit User Access"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 240
Left = 390
TabIndex = 7
Top = 60
Width = 1560
End
Begin VB.Image imgOKPicture
Height = 375
Index = 1
Left = 7230
Picture = "frmAccounts.frx":62BC6
Top = 450
Visible = 0 'False
Width = 1155
End
Begin VB.Image imgOKPicture
Height = 360
Index = 0
Left = 7230
Picture = "frmAccounts.frx":642B0
Stretch = -1 'True
Top = 60
Visible = 0 'False
Width = 1155
End
Begin VB.Label lblNew
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "New"
ForeColor = &H00C0FFC0&
Height = 195
Left = 780
TabIndex = 6
Tag = "ButtonLabel"
Top = 3360
Width = 345
End
Begin VB.Label lblSave
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Save"
Enabled = 0 'False
ForeColor = &H00C0FFC0&
Height = 195
Left = 1740
TabIndex = 5
Tag = "ButtonLabel"
Top = 3360
Width = 375
End
Begin VB.Label lblExit
Alignment = 2 'Center
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Exit"
ForeColor = &H00C0FFC0&
Height = 195
Left = 6090
TabIndex = 4
Tag = "ButtonLabel"
Top = 3360
Width = 255
End
Begin VB.Image imgExit
Height = 375
Left = 5730
Picture = "frmAccounts.frx":65CD2
Stretch = -1 'True
Top = 3270
Width = 975
End
Begin VB.Image imgNew
Height = 375
Left = 450
Picture = "frmAccounts.frx":676F4
Stretch = -1 'True
Top = 3270
Width = 975
End
Begin VB.Image imgSave
Enabled = 0 'False
Height = 375
Left = 1410
Picture = "frmAccounts.frx":69116
Stretch = -1 'True
Top = 3270
Width = 975
End
Begin VB.Image imgDelete
Height = 375
Left = 2370
Picture = "frmAccounts.frx":6AB38
Stretch = -1 'True
Top = 3270
Width = 975
End
Begin VB.Image imgHelp
Height = 375
Left = 4650
Picture = "frmAccounts.frx":6C55A
Stretch = -1 'True
Top = 3270
Width = 975
End
End
Attribute VB_Name = "frmAccounts"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim rec As New ADODB.Recordset
Dim flds As New ADODB.Recordset
Dim iDirty As Boolean
Dim dontWatchText As Boolean
Sub ClearAllControls()
On Local Error Resume Next
txtLoginName = ""
txtFullName = ""
txtPassWord = ""
txtLastLogin = ""
chkUserSecurity = False
iDirty = False
End Sub
Sub DeleteAccount()
On Local Error GoTo DeleteAccountError
If UserSecurity = False Then
MsgBox "You do not have authorization to delete your account. Contact your System Administrator", vbInformation, "Authorization..."
Exit Sub
End If
' Check for last Admin. If so, then disable save if Admin Access is off
If flds.State <> adStateClosed Then flds.Close
flds.Source = "Select * From Usernames where Admin = True"
flds.Open
If flds.RecordCount = 1 And chkUserSecurity = 1 Then
MsgBox "You cannot remove the only remaining Admin User.", vbCritical, "Admin Access"
flds.Close
Exit Sub
End If
flds.Close
'Confirm...
If MsgBox("Are you sure you want to delete " & UCase(txtFullName) & "s' account?", vbYesNo + vbQuestion, "Delete Account...") = vbNo Then
Exit Sub
End If
If flds.State <> adStateClosed Then flds.Close
flds.Source = "Select * From Usernames"
flds.Open
If flds.RecordCount = 1 Then
MsgBox "Deleting the last account would prevent anyone from accessing the software. You must make another account before deleting " & UCase(txtFullName), vbInformation, "Delete"
flds.Close
Exit Sub
End If
flds.Close
Dim IDnum As String
Dim IDTemp As Integer
IDTemp = InStr(1, lstUsers.Text, "-", vbTextCompare)
IDnum = Trim$(Left$(lstUsers.Text, IDTemp - 1))
dbcn.BeginTrans
dbcn.Execute "DELETE * FROM Usernames WHERE ID = " & IDnum
dbcn.CommitTrans
Call popList
Exit Sub
DeleteAccountError:
DB.Close
Call WriteToErrorLog(Me.Name, "DeleteAccountError", Error, Err, True)
Exit Sub
End Sub
Function SaveChanges() As Boolean
On Local Error GoTo SaveChangesError
'New code starts here -------------------
Dim IDnum As String
Dim IDTemp As Integer
IDTemp = InStr(1, lstUsers.Text, "-", vbTextCompare)
IDnum = Trim$(Left$(lstUsers.Text, IDTemp - 1))
' Check for info correct
If (Trim$(txtLoginName.Text) = "" Or Trim$(txtFullName.Text) = "" Or Trim$(txtPassWord.Text) = "") Then
MsgBox "Login Name, Full Name and Password fields must be filled before saving", vbInformation, "Error Saving..."
Exit Function
End If
' Check for last Admin. If so, then disable save if Admin Access is off
If flds.State <> adStateClosed Then flds.Close
flds.Source = "Select * From Usernames where Admin = True"
flds.Open
If flds.RecordCount = 1 And chkUserSecurity.Value = 0 Then
MsgBox "You cannot remove Admin Access to the only remaining Admin User.", vbCritical, "Admin Access"
flds.Close
Exit Function
End If
flds.Close
Dim xtemp As Boolean
xtemp = False
If chkUserSecurity.Value = 1 Then xtemp = True
'update user
dbcn.BeginTrans
dbcn.Execute "UPDATE Usernames SET LoginName = '" & Trim$(txtLoginName.Text) & _
"', FullName = '" & Trim$(txtFullName.Text) & _
"', Pwd = '" & Trim$(txtPassWord.Text) & _
"', Admin = " & xtemp & " WHERE ID = " & IDnum
dbcn.CommitTrans
iDirty = False
Call popList
Exit Function
SaveChangesError:
MsgBox "Error while trying to save username info. Contact technical support.", vbCritical, "Error"
Exit Function
End Function
Private Sub chkUserSecurity_Click()
If dontWatchText = False Then iDirty = True
End Sub
Private Sub chkUserSecurity_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Help.HelpText = "States whether the user has Administration privledges."
End Sub
Private Sub Form_Load()
'Load the main menu's form settings...
Call LoadINISettings
'Set program colors...
Call SetColors(Me)
'Form Coordinates...
Me.Width = QuickRef.MediumMenuWidth
Me.Height = QuickRef.MediumMenuHeight
rec.ActiveConnection = dbcn
' change this by closing and changing then reopening
rec.CursorLocation = adUseClient
'persisted in memory
rec.CursorType = adOpenStatic
rec.LockType = adLockBatchOptimistic
flds.ActiveConnection = dbcn
' change this by closing and changing then reopening
flds.CursorLocation = adUseClient
'persisted in memory
flds.CursorType = adOpenStatic
flds.LockType = adLockBatchOptimistic
' open record set
Call popList
iDirty = False
End Sub
Sub LoadINISettings()
'Form Coordinates...
Me.Left = val(ReadINI(Me.Name, "Left"))
Me.Top = val(ReadINI(Me.Name, "Top"))
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Move the form if the user is pressing and holding the mouse button...
If Button = vbLeftButton Then
Call DragForm(Me)
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Prompt to save first...
If iDirty Then
If MsgBox("Changes were not saved. Do you still want to exit anyway?", vbYesNo + vbQuestion, "Save Changes...") = vbNo Then
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -