frmaccounts.frm

一个外国人所编非常酷的数据库综合程序源码

        Cancel = True
        Exit Sub
    End If
End If

'Save INI Settings...
Call SaveINISettings

If rec.State <> adStateClosed Then rec.Close
Set rec = Nothing
    
If flds.State <> adStateClosed Then flds.Close
Set flds = Nothing

End Sub
Sub SaveINISettings()

'Form coordinates...
Call WriteINI(Me.Name, "Left", Me.Left)
Call WriteINI(Me.Name, "Top", Me.Top)

End Sub

Private Sub imgDelete_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgDelete.Picture = imgOKPicture(1).Picture
    lblDelete.ForeColor = QBColor(0)
End If

End Sub
Private Sub imgDelete_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgDelete.Picture = imgOKPicture(0).Picture
lblDelete.ForeColor = lButtonForeColor

End Sub

Private Sub imgHelp_Click()

lblHelp_Click

End Sub
Private Sub imgHelp_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgHelp.Picture = imgOKPicture(1).Picture
    lblHelp.ForeColor = QBColor(0)
End If

End Sub
Private Sub imgHelp_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgHelp.Picture = imgOKPicture(0).Picture
lblHelp.ForeColor = lButtonForeColor

End Sub
Private Sub imgNew_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgNew.Picture = imgOKPicture(1).Picture
    lblNew.ForeColor = QBColor(0)
End If

End Sub
Private Sub imgNew_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgNew.Picture = imgOKPicture(0).Picture
lblNew.ForeColor = lButtonForeColor

End Sub
Private Sub imgExit_Click()

lblExit_Click

End Sub

Private Sub imgExit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgExit.Picture = imgOKPicture(1).Picture
    lblExit.ForeColor = QBColor(0)
End If

End Sub
Private Sub imgExit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgExit.Picture = imgOKPicture(0).Picture
lblExit.ForeColor = lButtonForeColor

End Sub
Private Sub imgSave_Click()

lblSave_Click

End Sub

Private Sub imgSave_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgSave.Picture = imgOKPicture(1).Picture
    lblSave.ForeColor = QBColor(0)
End If

End Sub
Private Sub imgSave_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgSave.Picture = imgOKPicture(0).Picture
lblSave.ForeColor = lButtonForeColor

End Sub

Private Sub lblDelete_Click()

'Delete account...
Call DeleteAccount

End Sub
Private Sub lblDelete_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgDelete.Picture = imgOKPicture(1).Picture
    lblDelete.ForeColor = QBColor(0)
End If

End Sub

Private Sub lblDelete_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Deletes this user from the system."

End Sub
Private Sub lblDelete_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgDelete.Picture = imgOKPicture(0).Picture
lblDelete.ForeColor = lButtonForeColor

End Sub

Private Sub lblExit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Exit this screen."

End Sub

Private Sub lblHelp_Click()

Help.HelpCallingForm = Me.Name

frmHelper.Show
frmHelper.ZOrder

End Sub
Private Sub lblHelp_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgHelp.Picture = imgOKPicture(1).Picture
    lblHelp.ForeColor = QBColor(0)
End If

End Sub

Private Sub lblHelp_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Shows the Help Window."

End Sub
Private Sub lblHelp_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgHelp.Picture = imgOKPicture(0).Picture
lblHelp.ForeColor = lButtonForeColor

End Sub
Private Sub lblNew_Click()

On Local Error GoTo lblNew_ClickError

If UserSecurity = False Then
    MsgBox "You do not have authorization to create new accounts. Contact your System Administrator", vbInformation, "Authorization..."
    Exit Sub
End If

Dim sInput As String
Dim sInput2 As String
Dim sInput3 As String

'Enter a new user name...
sInput2 = Trim$(InputBox$("Enter the user's FULL NAME for this new account.", "New Account..."))
If sInput2 = "" Then Exit Sub

'Enter a new user name...
sInput = Trim$(InputBox$("Enter the user's LOGIN NAME for this new account.", "New Account..."))
If sInput = "" Then Exit Sub

'Enter a new user name...
sInput3 = Trim$(InputBox$("Enter the user's PASSWORD for this new account.", "New Account..."))
If sInput3 = "" Then Exit Sub

'Clear out all controls...
Call ClearAllControls

txtFullName = sInput2
txtLoginName = sInput
txtPassWord = sInput3
'txtLoginName = sInput2

dbcn.BeginTrans
dbcn.Execute "INSERT INTO Usernames ( LoginName , FullName, Pwd) " & _
    "Values ('" & sInput & "', '" & sInput2 & "', '" & sInput3 & "')"
dbcn.CommitTrans
    
iDirty = False
Call popList
Exit Sub

lblNew_ClickError:
    'DB.Close
    'Call WriteToErrorLog(Me.Name, "lblNew_ClickError", Error$, Err, True)
    MsgBox "Error occured while trying to create a new user account. Contact Technical Support"
    Exit Sub
    Resume Next

End Sub

Private Sub lblNew_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Click here to create a new user."

End Sub
Private Sub lblSave_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Saves any changes you have made to this user."

End Sub
Private Sub lblSystemAccounts_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 lblNew_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgNew.Picture = imgOKPicture(1).Picture
    lblNew.ForeColor = QBColor(0)
End If

End Sub
Private Sub lblNew_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgNew.Picture = imgOKPicture(0).Picture
lblNew.ForeColor = lButtonForeColor

End Sub
Private Sub lblExit_Click()

'Unload the help window...
If Help.HelpCallingForm = Me.Name Then
    Unload frmHelper
End If

Unload Me

End Sub
Private Sub lblExit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgExit.Picture = imgOKPicture(1).Picture
    lblExit.ForeColor = QBColor(0)
End If

End Sub
Private Sub lblExit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgExit.Picture = imgOKPicture(0).Picture
lblExit.ForeColor = lButtonForeColor

End Sub
Private Sub lblSave_Click()

Call SaveChanges

End Sub
Private Sub lblSave_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
    imgSave.Picture = imgOKPicture(1).Picture
    lblSave.ForeColor = QBColor(0)
End If

End Sub

Private Sub lblSave_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

imgSave.Picture = imgOKPicture(0).Picture
lblSave.ForeColor = lButtonForeColor

End Sub
Private Sub lstUsers_Click()

On Local Error Resume Next

Dim iLocalIPHasChanged As Boolean


'Clear out all of the fields...
Call ClearAllControls

    Dim IDnum As String
    Dim IDTemp As Integer

    IDTemp = InStr(1, lstUsers.Text, "-", vbTextCompare)
    IDnum = Trim$(Left$(lstUsers.Text, IDTemp - 1))

    
    
    If IDnum <> "" Then
    'MsgBox ("active record selected... filling text fields")
    If flds.State <> adStateClosed Then flds.Close
    flds.Source = "Select * From Usernames where ID = " & IDnum
    flds.Open
    
    Call ClearAllControls
    dontWatchText = True
    
    If Not IsNull(flds.Fields(1).Value) Then
        txtLoginName.Text = flds.Fields(1).Value
    End If
    If Not IsNull(flds.Fields(2).Value) Then
        txtFullName.Text = flds.Fields(2).Value
    End If
    If Not IsNull(flds.Fields(3).Value) Then
        txtPassWord.Text = flds.Fields(3).Value
    End If
    If Not IsNull(flds.Fields(4).Value) Then
        txtLastLogin.Text = FormatDateTime(flds.Fields(4).Value, vbLongDate)
    End If
    'MsgBox "Check box is " & chkUserSecurity & vbCrLf & "Field value is " & flds.Fields(5).Value
    If flds.Fields(5).Value = True Then chkUserSecurity = 1
     
    dontWatchText = False
    iDirty = (iLocalIPHasChanged = True)
    End If

End Sub

Private Sub lstUsers_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Listing of all users currently set up in the system."

End Sub
Private Sub Timer1_Timer()

On Local Error Resume Next

'Users Listbox...
lstUsers.Enabled = iDirty = False

'New...
If imgNew.Enabled = False And iDirty = False Then
    imgNew.Enabled = True
    lblNew.Enabled = True
ElseIf imgNew.Enabled = True And iDirty = True Then
    imgNew.Enabled = False
    lblNew.Enabled = False
End If

'Save...
If imgSave.Enabled = False And iDirty = True Then
    imgSave.Enabled = True
    lblSave.Enabled = True
ElseIf imgSave.Enabled = True And iDirty = False Then
    imgSave.Enabled = False
    lblSave.Enabled = False
End If

'Delete...
If imgDelete.Enabled = True And lstUsers.List(lstUsers.ListIndex) = "Administrator" And iDirty = False Then
    imgDelete.Enabled = False
    lblDelete.Enabled = False
ElseIf imgDelete.Enabled = False And lstUsers.List(lstUsers.ListIndex) <> "Administrator" And iDirty = False Then
    imgDelete.Enabled = True
    lblDelete.Enabled = True
End If

End Sub

Private Sub txtFullName_Change()

If dontWatchText = False Then iDirty = True

End Sub

Private Sub txtFullName_GotFocus()

txtFullName.SelStart = 0
txtFullName.SelLength = Len(txtFullName)

End Sub

Private Sub txtFullName_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Type in this users full name here."

End Sub

Private Sub txtLastLogin_Change()

If dontWatchText = False Then iDirty = True
End Sub

Private Sub txtLastLogin_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "The last time the selected user accessed the database."

End Sub

Private Sub txtLoginName_Change()

If dontWatchText = False Then iDirty = True

End Sub
Private Sub txtLoginName_GotFocus()

txtLoginName.SelStart = 0
txtLoginName.SelLength = Len(txtLoginName)

End Sub

Private Sub txtLoginName_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Type in the users login name here."

End Sub
Private Sub txtPassWord_Change()

If dontWatchText = False Then iDirty = True

End Sub

Private Sub txtPassWord_GotFocus()

txtPassWord.SelStart = 0
txtPassWord.SelLength = Len(txtPassWord)

End Sub

Private Sub txtPassWord_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Help.HelpText = "Type in a password for this user to log in with."

End Sub

Private Sub popList()
    
    lstUsers.Clear
    
    Dim t As Integer
    Dim listRow As String
    t = 0
    If rec.State <> adStateClosed Then rec.Close
    If (UserSecurity = True) Then
        rec.Source = "Select * From Usernames"
        chkUserSecurity.Visible = True
        lblUserSecurity.Visible = True
    Else
        rec.Source = "Select * From Usernames where ID = " & CurrentUser
        chkUserSecurity.Visible = False
        lblUserSecurity.Visible = False
    End If
    rec.Open
    rec.MoveFirst
       
    While Not rec.EOF
        'add to listRow string and poplulate listbox
        listRow = rec.Fields(0).Value & " - " & rec.Fields(2).Value
        lstUsers.AddItem listRow, t
        
        t = t + 1
        rec.MoveNext
    Wend
    rec.Close
    lstUsers.ListIndex = 0
   
End Sub