frmexampledb.frm

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

On Local Error GoTo SaveChangesError

'New code starts here -------------------
Dim fullnam As String
fullnam = txtLast_Name.Text & ", " & txtFirst_Name.Text
Dim IDnum As String
IDnum = Trim$(txtID.Text)

' Check for Current Past or Future studnet info correct
Dim tempCheck As String
txtCurrent_Past.Text = Trim$(UCase(txtCurrent_Past.Text))
tempCheck = txtCurrent_Past.Text
If tempCheck <> "F" And tempCheck <> "C" And tempCheck <> "P" Then
    If tempCheck = "" Then
        txtCurrent_Past.Text = "C"
    Else
        Dim FCPInput As String
        Dim FCP As Boolean
        FCP = False
        While (FCP = False)
            FCPInput = UCase(InputBox$("Please Specify" & vbCrLf & vbCrLf & "    F - Future Student" & vbCrLf & "    C - Current Student" & vbCrLf & "    P - Past Student", "Future, Current Or Past Student"))
            If (FCPInput = "P" Or FCPInput = "C" Or FCPInput = "F") Then FCP = True
        Wend
        txtCurrent_Past.Text = FCPInput
    End If
End If

' Check for full or part time student info correct
txtFull_Part.Text = Trim$(UCase(txtFull_Part.Text))
tempCheck = txtFull_Part.Text
If tempCheck <> "F" And tempCheck <> "P" Then
    If tempCheck = "" Then
        txtFull_Part.Text = "F"
    Else
        FCP = False
        While (FCP = False)
            FCPInput = UCase(InputBox$("Please Specify" & vbCrLf & vbCrLf & "    F - Full Time Student" & vbCrLf & "    P - Part Time Student", "Full or Part Time Student"))
            If (FCPInput = "P" Or FCPInput = "F") Then FCP = True
        Wend
        txtFull_Part.Text = FCPInput
    End If
End If

'IDnum = Trim$(Left$(DataList1.Text, InStr(1, DataList1.Text, " ", vbTextCompare)))
dbcn.BeginTrans
dbcn.Execute "UPDATE data SET " & _
    "Last_Name = '" & Trim$(txtLast_Name.Text) & _
    "', First_Name = '" & Trim$(txtFirst_Name.Text) & _
    "', Full_Name = '" & Trim$(fullnam) & _
    "', C_Address = '" & Trim$(txtC_Address.Text) & _
    "', C_City = '" & Trim$(txtC_City.Text) & _
    "', C_Province = '" & Trim$(txtC_Province.Text) & _
    "', C_PostalCode = '" & Trim$(txtC_PostalCode.Text) & _
    "', C_Telephone = '" & Trim$(txtC_Telephone.Text) & "' WHERE ID = " & IDnum
dbcn.Execute "UPDATE data SET " & _
    "FirstNation = '" & Trim$(txtFirstNation.Text) & _
    "', FirstNation_Contact = '" & Trim$(txtFirstNation_Contact.Text) & _
    "', FirstNation_Telephone = '" & Trim$(txtFirstNation_Telephone.Text) & _
    "', P_Address = '" & Trim$(txtP_Address.Text) & _
    "', P_City = '" & Trim$(txtP_City.Text) & _
    "', P_Province = '" & Trim$(txtP_Province.Text) & "' WHERE ID = " & IDnum
dbcn.Execute "UPDATE data SET " & _
    "P_PostalCode = '" & Trim$(txtP_PostalCode.Text) & _
    "', P_Telephone = '" & Trim$(txtP_Telephone.Text) & _
    "', Program = '" & Trim$(txtProgram.Text) & _
    "', Program_Length = '" & Trim$(txtProgram_Length.Text) & _
    "', Last_Course = '" & Trim$(txtLast_Course.Text) & _
    "', Enroll = '" & Trim$(txtEnroll.Text) & _
    "', Grad = '" & Trim$(txtGrad.Text) & "' WHERE ID = " & IDnum
dbcn.Execute "UPDATE data SET " & _
    "Current_Past = '" & Trim$(txtCurrent_Past.Text) & _
    "', Full_Part = '" & Trim$(txtFull_Part.Text) & _
    "', Grad_Studies = '" & Trim$(txtGrad_Studies.Text) & _
    "', Institution = '" & Trim$(txtInstitution.Text) & _
    "', Job_Title = '" & Trim$(txtJob_Title.Text) & _
    "', Employer = '" & Trim$(txtEmployer.Text) & "' WHERE ID = " & IDnum

dbcn.Execute "UPDATE data SET Updat = '" & Now & "' WHERE ID = " & IDnum
dbcn.CommitTrans
    
txtUpdate.Text = FormatDateTime(Now, vbLongDate)

SaveChanges = True
iDirty = False
QuickRef.UpdateNotes = QuickRef.NotesHaveChanged

Exit Function


SaveChangesError:
    'DB.Close
    MsgBox (" Error occurred while saving ... Partial or all data was updated")
    'Call WriteToErrorLog(Me.Name, "SaveChanges", Error, Err, True)
    Exit Function
    Resume Next

End Function
Private Sub btnColors_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Colors...
If lblColors.Enabled Then
    lblColors_Click
End If

End Sub
Private Sub btnDelete_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Delete...
If lblDelete.Enabled Then
    lblDelete_Click
End If

End Sub

Private Sub btnExit_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Exit...
If lblExit.Enabled Then
    lblExit_Click
End If

End Sub

Private Sub btnHelp_Click()
'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Help...
If lblHelp.Enabled Then
    lblHelp_Click
End If
End Sub

Private Sub btnNew_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'New...
If lblNew.Enabled Then
    lblNew_Click
End If

End Sub

Private Sub btnNotes_Click()
'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Exit...
If lblNotes.Enabled Then
    lblNotes_Click
End If
End Sub

Private Sub btnPrint_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Print...
If lblPrint.Enabled Then
    lblPrint_Click
End If

End Sub

Private Sub btnQKeys_Click()
    lblQKeys_Click
End Sub

Private Sub btnReload_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Reload...
If lblReload.Enabled Then
    lblReload_Click
End If

End Sub
Private Sub btnSave_Click()

'These buttons are hidden. I am using them simply for the hot keys (ALT + Key)...

'Save...
If lblSave.Enabled Then
    lblSave_Click
End If

End Sub

Private Sub DataList1_Click()

On Error GoTo DataListClickError
   
dontWatchText = True
Dim IDnum As String
Dim IDTemp As Integer

IDTemp = InStr(1, DataList1.Text, "(", vbTextCompare)
If IDTemp = 0 Then Exit Sub
IDnum = Trim$(Right$(DataList1.Text, Len(DataList1.Text) - IDTemp))
IDnum = Trim$(Left$(IDnum, Len(IDnum) - 1))

If IDnum <> "" Then

If rep.State <> adStateClosed Then rep.Close
rep.Source = "Select * From data where ID = " & IDnum
rep.Open
    
Call ClearAllFields
If Not IsNull(rep.Fields(0).Value) Then
    txtID.Text = rep.Fields(0).Value
End If
If Not IsNull(rep.Fields(2).Value) Then
    txtLast_Name.Text = rep.Fields(2).Value
End If
If Not IsNull(rep.Fields(3).Value) Then
    txtFirst_Name = rep.Fields(3).Value
End If

If Not IsNull(rep.Fields(4).Value) Then
    txtC_Address = rep.Fields(4).Value
End If
If Not IsNull(rep.Fields(5).Value) Then
    txtC_City.Text = rep.Fields(5).Value
End If
If Not IsNull(rep.Fields(6).Value) Then
    txtC_Province.Text = rep.Fields(6).Value
End If
If Not IsNull(rep.Fields(7).Value) Then
    txtC_PostalCode.Text = rep.Fields(7).Value
End If
If Not IsNull(rep.Fields(8).Value) Then
    txtC_Telephone.Text = rep.Fields(8).Value
End If

If Not IsNull(rep.Fields(9).Value) Then
    txtP_Address.Text = rep.Fields(9).Value
End If
If Not IsNull(rep.Fields(10).Value) Then
    txtP_City.Text = rep.Fields(10).Value
End If
If Not IsNull(rep.Fields(11).Value) Then
    txtP_Province.Text = rep.Fields(11).Value
End If
If Not IsNull(rep.Fields(12).Value) Then
    txtP_PostalCode.Text = rep.Fields(12).Value
End If
If Not IsNull(rep.Fields(13).Value) Then
    txtP_Telephone.Text = rep.Fields(13).Value
End If

If Not IsNull(rep.Fields(14).Value) Then
    txtFirstNation.Text = rep.Fields(14).Value
End If
If Not IsNull(rep.Fields(15).Value) Then
    txtFirstNation_Telephone.Text = rep.Fields(15).Value
End If
If Not IsNull(rep.Fields(16).Value) Then
    txtFirstNation_Contact.Text = rep.Fields(16).Value
End If

If Not IsNull(rep.Fields(17).Value) Then
    txtProgram.Text = rep.Fields(17).Value
End If
If Not IsNull(rep.Fields(18).Value) Then
    txtProgram_Length.Text = rep.Fields(18).Value
End If
If Not IsNull(rep.Fields(19).Value) Then
    txtLast_Course.Text = rep.Fields(19).Value
End If

If Not IsNull(rep.Fields(20).Value) Then
    txtEnroll.Text = rep.Fields(20).Value
End If
If Not IsNull(rep.Fields(21).Value) Then
    txtGrad.Text = rep.Fields(21).Value
End If
If Not IsNull(rep.Fields(22).Value) Then
    txtGrad_Studies.Text = rep.Fields(22).Value
End If
If Not IsNull(rep.Fields(23).Value) Then
    txtJob_Title.Text = rep.Fields(23).Value
End If
If Not IsNull(rep.Fields(24).Value) Then
    txtCurrent_Past.Text = rep.Fields(24).Value
End If
If Not IsNull(rep.Fields(25).Value) Then
    txtFull_Part.Text = rep.Fields(25).Value
End If
If Not IsNull(rep.Fields(26).Value) Then
    txtInstitution.Text = rep.Fields(26).Value
End If
If Not IsNull(rep.Fields(27).Value) Then
    txtEmployer.Text = rep.Fields(27).Value
End If
If Not IsNull(rep.Fields(28).Value) Then
    txtUpdate.Text = FormatDateTime(rep.Fields(28).Value, vbLongDate)
End If

dontWatchText = False
iDirty = False
iStudentNameHasChanged = False
End If
Exit Sub

DataListClickError:
    MsgBox "Error while processing Data List Event. Call Technical Support", vbCritical, "Error..."
    Exit Sub

    
End Sub

Private Sub DataList1_KeyDown(KeyCode As Integer, Shift As Integer)

'Delete key...
If KeyCode = vbKeyDelete And lblDelete.Enabled = True Then
    lblDelete_Click
End If

End Sub


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

Help.HelpText = "Click here to view information on a student."

End Sub

Private Sub Form_DblClick()

On Local Error Resume Next

'Change the windowstate...
If Me.WindowState = vbNormal Then
    Me.WindowState = vbMinimized
ElseIf Me.WindowState = vbMinimized Then
    Me.WindowState = vbNormal
End If

End Sub
Private Sub Form_Load()

List1.AddItem "Future"
List1.AddItem "Current"
List1.AddItem "Past"
List1.ListIndex = 1

rec.ActiveConnection = dbcn
' change this  by closing and changing then reopening
rec.CursorLocation = adUseClient
'persisted in memory
rec.CursorType = adOpenStatic
rec.LockType = adLockBatchOptimistic

' open record set
Call popList

rep.ActiveConnection = dbcn
' change this  by closing and changing then reopening
rep.CursorLocation = adUseClient
'persisted in memory
rep.CursorType = adOpenStatic
rep.LockType = adLockBatchOptimistic


On Local Error Resume Next
'Load INI Settings...
Call LoadINISettings

'Set Colors...
Call SetColors(Me)

'Set form width and height...
Me.Height = QuickRef.LargeMenuHeight
Me.Width = QuickRef.LargeMenuWidth

iDirty = False
iStudentNameHasChanged = False
QuickRef.NotesHaveChanged = False
QuickRef.UpdateNotes = False

End Sub
Sub LoadINISettings()

'Form Coordinates...
Me.Left = val(ReadINI(Me.Name, "Left"))
Me.Top = val(ReadINI(Me.Name, "Top"))

End Sub
Sub SaveINISettings()

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

End Sub

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

Help.HelpText = ""

'Move the form...
If Button = vbLeftButton And Me.WindowState = vbNormal Then
    Call DragForm(Me)
End If

End Sub
Private Sub Form_Unload(Cancel As Integer)
    
If rec.State <> adStateClosed Then rec.Close
Set rec = Nothing
    
If rep.State <> adStateClosed Then rep.Close
Set rep = Nothing

'Save INI Settings...
Call SaveINISettings

'Call appTerminate

End Sub

Private Sub imgColors_Click()

lblColors_Click