IRCForumları - IRC ve mIRC Kullanıcılarının Buluşma Noktası
  sohbet

Yeni Konu aç Cevapla
 
LinkBack Seçenekler Stil
Alt 19 Temmuz 2008, 16:52   #1
Çevrimdışı
Yardımcı Admin
Kullanıcıların profil bilgileri misafirlere kapatılmıştır.
IF Ticaret Sayısı: (0)
IF Ticaret Yüzdesi:(%)
Adres Defter Programı




ALINTIDIR

PHP Kod:   Kodu kopyalamak için üzerine çift tıklayın!
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 " 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 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"SendTovbNullStringvbNullStringSW_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.Number16"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 


__________________
[Üye Olmadan Linkleri Göremezsiniz. Üye Olmak için TIKLAYIN...]

[Üye Olmadan Linkleri Göremezsiniz. Üye Olmak için TIKLAYIN...]
 
Alıntı ile Cevapla

IRCForumlari.NET Reklamlar
sohbet odaları sohbet odaları Benimmekan Mobil Sohbet
Cevapla

Etiketler
adres, defter, programı


Konuyu Toplam 1 Üye okuyor. (0 Kayıtlı üye ve 1 Misafir)
 
Seçenekler
Stil

Yetkileriniz
Konu Acma Yetkiniz Yok
Cevap Yazma Yetkiniz Yok
Eklenti Yükleme Yetkiniz Yok
Mesajınızı Değiştirme Yetkiniz Yok

BB code is Açık
Smileler Açık
[IMG] Kodları Açık
HTML-Kodu Kapalı
Trackbacks are Kapalı
Pingbacks are Açık
Refbacks are Açık


Benzer Konular
Konu Konuyu Başlatan Forum Cevaplar Son Mesaj
Japonca Adres Sorma - Japonca Nasil Adres Sorabilirim PySSyCaT Yabancı Diller 0 01 Kasım 2014 15:24
Defter Kapakları Liaaa Türkçe 0 11 Mart 2012 00:23
Ücretsiz Adres Programı V2.22 CerenBlg Bilgisayar Donanımı 0 02 Şubat 2011 12:39