Cemalizim | 19 Temmuz 2008 16:52 | Adres Defter Programı ALINTIDIR PHP- Kodu: 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
|