Adres Defter Programı

 
Dim TR As Long
Dim ws As Workspace
Dim db As Database
Dim rs As Recordset
Dim datDate As Date



Private Sub Form_Load()
datDate = CDate(Format(Now(), "MMMM,D,YYYY"))
lblDate = datDate
lblStatus = "Program started successfully"
Provider = "Microsoft.Jet.OLEDB.4.0"
Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase(App.Path & "\AB.mdb")
With Data1
.DatabaseName = App.Path & "\AB.mdb"
.RecordSource = "idxAB"
.Refresh
End With
'Check to see if recordcount is 0
On Error Resume Next
Data1.Recordset.MoveFirst
TR = Data1.Recordset.RecordCount
Screen.MousePointer = vbDefault
If TR > 0 Then
txtFields(0).Enabled = True
txtFields(1).Enabled = True
txtFields(2).Enabled = True
txtFields(3).Enabled = True
txtFields(4).Enabled = True
txtFields(5).Enabled = True
txtFields(6).Enabled = True
txtFields(7).Enabled = True
txtFields(8).Enabled = True
cmdDelete.Enabled = True
cmdUpdate.Enabled = True
cmdNext.Enabled = True
cmdPrev.Enabled = True
cmdFind.Enabled = True
cmdemail.Enabled = True
mnuReport.Enabled = True
mnuData.Enabled = True
' Data1.Recordset.MoveFirst
lblStatus = "Program started successfully"
lblBar.Caption = "Record: " & (Data1.Recordset.AbsolutePosition + 1 & " of " & (Data1.Recordset.RecordCount))
End If

'Check if copy of program is already running
If App.PrevInstance Then
MsgBox "Address Book is already running in memory", vbOKOnly, "Address Book Running"
ActivatePrevInstance
End If
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
End Sub

Private Sub cmdAbout_Click()
'Open About form
frmAbout.Show
End Sub

Private Sub cmdAdd_Click()
'Add record
On Error GoTo ErrHandle
If TR = 0 Then
TR = TR + 1
txtFields(0).Enabled = True
txtFields(1).Enabled = True
txtFields(2).Enabled = True
txtFields(3).Enabled = True
txtFields(4).Enabled = True
txtFields(5).Enabled = True
txtFields(6).Enabled = True
txtFields(7).Enabled = True
txtFields(8).Enabled = True
cmdAdd.Enabled = True
cmdDelete.Enabled = True
cmdNext.Enabled = True
cmdPrev.Enabled = True
cmdFind.Enabled = True
cmdUpdate.Enabled = True
cmdemail.Enabled = True
mnuReport.Enabled = True
mnuData.Enabled = True
End If
txtFields(0).SetFocus
Data1.Recordset.AddNew
lblStatus = "Adding new record"

End_of_Proc:
Exit Sub

ErrHandle:
lblStatus = "Error number " & Err.Number & " encountered."
Select Case Err.Number
Case 3426
MsgBox ("Each record requires a Last & First name !"), vbOKOnly
If txtFields(0) = "" Then
txtFields(0).SetFocus
Else
txtFields(1).SetFocus
End If
Screen.MousePointer = vbDefault
Resume Next
Case Else
MsgBox "Unknown error has been encountered Saving record!" _
& Space(1) & "Note the Error number" & Space(1) & Err.Number, vbOKOnly
Screen.MousePointer = vbDefault
Resume Next
End Select
Err.Number = 0
End Sub

Private Sub cmdDelete_Click()
'Delete record
txtFields(0).SetFocus
TR = Data1.Recordset.RecordCount
Data1.Recordset.Delete
lblStatus = "Deleted Record" & Space(1) & txtFields(1) & Space(1) & txtFields(0)
Data1.Refresh

If TR = 1 And txtFields(0).Text = "" Then
TR = 0
Data1.Refresh
MsgBox "Last record removed from database!", 48
Else
TR = TR + 1
Data1.Refresh
End If
End Sub

Private Sub cmdemail_Click()
'Send e-mail to user listed
lblStatus = "Sending e-mail"
SendTo = txtFields(6).Text

If SendTo = "" Then
MsgBox "There is no email address entered!", 48, "Error sending e-mail"
lblStatus = lblStatus & " failed."
Else
SendTo = "mailto:" & SendTo
ShellExecute hwnd, "open", SendTo, vbNullString, vbNullString, SW_SHOWDEFAULT
End If
End Sub

Private Sub cmdFind_Click()
'Search for first record matching users request
sstr = InputBox("Enter Last Name to Search")
If sstr = "" Then
Exit Sub
Else
lblStatus = "Search Results for " & sstr
Data1.Recordset.FindFirst "Lname='" & sstr & "'"
If Data1.Recordset.NoMatch Then
MsgBox UCase(sstr) & " was not found in the database, check your spelling!", 48, "Search failed"
lblStatus = lblStatus & " failed."
End If
End If
End Sub

Private Sub cmdNext_Click()
'Move to next record if not EOF
If Data1.Recordset.BOF = True Or Data1.Recordset.EOF = True Then
If Data1.Recordset.EOF = True Then
MsgBox "End of file reached", 48, "Record Warning"
End If
Else
Data1.Recordset.MoveNext
If txtFields(0).Text = "" Then
MsgBox "End of file reached", 48, "Record Warning"
Data1.Recordset.MoveLast
End If
End If
End Sub

Private Sub cmdPrev_Click()
'Move to previous record if not at BOF
If Data1.Recordset.BOF = True Or Data1.Recordset.EOF = True Then
If Data1.Recordset.BOF = True Then
MsgBox "Beginning of file reached", 48, "Record Warning"
End If
Else
Data1.Recordset.MovePrevious
If txtFields(0).Text = "" Then
MsgBox "Beginning of file reached", 48, "Record Warning"
Data1.Recordset.MoveFirst
End If
End If
End Sub

Private Sub cmdUpdate_Click()
'Save changes to database & check for errors
On Error GoTo ErrHandle
cmdUpdate.SetFocus
Data1.UpdateRecord
Data1.Recordset.Bookmark = Data1.Recordset.LastModified
lblStatus = "Saved record" & Space(1) & txtFields(1) & Space(1) & txtFields(0)

End_of_Proc:
Exit Sub

ErrHandle:
lblStatus = "Error number " & Err.Number & " encountered."
Select Case Err.Number
Case 3058
MsgBox ("Each record requires a Last & First name !"), vbOKOnly
Resume End_of_Proc
Case 524
If txtFields(0) = "" Then
MsgBox ("Last name must be filled in!"), vbOKOnly
txtFields(0).SetFocus
Else
MsgBox ("First name must be filled in!"), vbOKOnly
txtFields(1).SetFocus
End If
Resume End_of_Proc:
Case 0
Resume Next
Case Else
MsgBox "An error has been encountered Saving record!" _
& Space(1) & "Note the Error number" & Space(1) & Err.Number, vbOKOnly

Resume End_of_Proc:
End Select
End Sub

Private Sub cmdClose_Click()
'Close program
Unload Me
End Sub

Private Sub Data1_Reposition()
'Update lblBar with records info
On Error Resume Next
Screen.MousePointer = vbDefault
If TR = 0 Then
lblStatus.Caption = "Click Add to Start"
txtFields(0).Enabled = False
txtFields(1).Enabled = False
txtFields(2).Enabled = False
txtFields(3).Enabled = False
txtFields(4).Enabled = False
txtFields(5).Enabled = False
txtFields(6).Enabled = False
txtFields(7).Enabled = False
txtFields(8).Enabled = False
cmdDelete.Enabled = False
cmdUpdate.Enabled = False
cmdNext.Enabled = False
cmdPrev.Enabled = False
cmdFind.Enabled = False
cmdemail.Enabled = False
mnuReport.Enabled = False
mnuData.Enabled = False
lblBar.Caption = "Database is empty"
Else
lblBar.Caption = "Record: " & (Data1.Recordset.AbsolutePosition + 1 & " of " & (Data1.Recordset.RecordCount))
End If
End Sub

Private Sub Data1_Validate(Action As Integer, Save As Integer)
'Check for what action was taken
Select Case Action
Case vbdataActionMaximixe
Case vbDataActionMoveFirst
Case vbDataActionMovePrevious
Case vbDataActionMoveNext
Case vbDataActionMoveLast
Case vbDataActionAddNew
Case vbDataActionUpdate
Case vbDataActionDelete
Case vbDataActionFind
Case vbDataActionBookmark
Case vbDataActionClose

End Select
Screen.MousePointer = vbHourglass
End Sub

Private Sub mnuAbout_Click()
frmAbout.Show
End Sub

Private Sub mnuDelete_Click()
'Delete record
txtFields(0).SetFocus
TR = Data1.Recordset.RecordCount
Data1.Recordset.Delete
lblStatus = "Deleted Record" & Space(1) & txtFields(1) & Space(1) & txtFields(0)
Data1.Refresh

If TR = 1 And txtFields(0) = "" Then
TR = 0
Data1.Refresh
MsgBox "Last record removed from database!", 48
Else
TR = TR + 1
Data1.Refresh
End If
End Sub

Private Sub mnuemail_Click()
'Send e-mail to user listed
lblStatus = "Sending e-mail"
SendTo = txtFields(6).Text

If SendTo = "" Then
MsgBox "There is no email address entered!", 48, "Error sending e-mail"
lblStatus = lblStatus & " failed."
Else
SendTo = "mailto:" & SendTo
ShellExecute hwnd, "open", SendTo, vbNullString, vbNullString, SW_SHOWDEFAULT
End If
End Sub

Private Sub mnuExit_Click()
Unload Me
End Sub


Private Sub mnuNext_Click()
'Move to next record if not EOF
If Data1.Recordset.BOF = True Or Data1.Recordset.EOF = True Then
If Data1.Recordset.EOF = True Then
MsgBox "End of file reached", 48, "Record Warning"
End If
Else
Data1.Recordset.MoveNext
If txtFields(0).Text = "" Then
MsgBox "End of file reached", 48, "Record Warning"
Data1.Recordset.MoveLast
End If
End If
End Sub

Private Sub mnuPrev_Click()
'Move to previous record if not at BOF
If Data1.Recordset.BOF = True Or Data1.Recordset.EOF = True Then
If Data1.Recordset.BOF = True Then
MsgBox "Beginning of file reached", 48, "Record Warning"
End If
Else
Data1.Recordset.MovePrevious
If txtFields(0).Text = "" Then
MsgBox "Beginning of file reached", 48, "Record Warning"
Data1.Recordset.MoveFirst
End If
End If
End Sub

Private Sub mnuReadMe_Click()
ReadMe.Show
End Sub

Private Sub mnuReport_Click()
On Error GoTo ErrRpt
DataRpt.Show


End_of_Proc:
Exit Sub

ErrRpt:
Select Case Err.Number
Case 713
MsgBox "Missing required file Msdbrptr.dll to run the report feature", 16, "Vew Report Critical Error"
Resume Next
Case Else
MsgBox "An unknown error has halted the View Report" & Err.Number, 16, "View Report Critical Error"
Resume Next
End Select
End Sub

Private Sub mnuSave_Click()
'Save changes to database & check for errors
On Error GoTo ErrHandle
cmdUpdate.SetFocus
Data1.UpdateRecord
Data1.Recordset.Bookmark = Data1.Recordset.LastModified
lblStatus = "Saved record" & Space(1) & txtFields(1) & Space(1) & txtFields(0)

End_of_Proc:
Exit Sub

ErrHandle:
lblStatus = "Error number " & Err.Number & " encountered."
Select Case Err.Number
Case 3058
MsgBox ("Each record requires a Last & First name !"), vbOKOnly
Resume End_of_Proc
Case 524
If txtFields(0) = "" Then
MsgBox ("Last name must be filled in!"), vbOKOnly
txtFields(0).SetFocus
Else
MsgBox ("First name must be filled in!"), vbOKOnly
txtFields(1).SetFocus
End If
Resume End_of_Proc:
Case 0
Resume Next
Case Else
MsgBox "An error has been encountered Saving record!" _
& Space(1) & "Note the Error number" & Space(1) & Err.Number, vbOKOnly

Resume End_of_Proc:
End Select
End Sub

Yorum Yapabilmek İçin Üye Girişi Yapmanız Gerekmektedir.

adres defter programı