Tipp 0278 Datensätze bearbeiten, suchen und drucken
Autor/Einsender:
Datum:
  Dinko Hasanbasic
12.10.2002
Entwicklungsumgebung:   VB 6
Diesen Tipp könnte man als Grundlage für eine eigene Adressdatenbank benutzen. Es können Einträge hinzugefügt, gelöscht und gedruckt werden, eine Suchfunktion ist auch integriert. Das "Herz" des Projekts ist die Klasse Adressbuch. In ihr befinden sich alle wichtigen Variablen, Eigenschaften (Properties) und Routinen. Diesem Tipp ist auch eine Hilfe-Datei beigefügt, in der nähere Erläuterungen zu finden sind.
Code im Codebereich des Klassenmoduls Adressbuch
 
Option Explicit

Private mvarVorname As String
Private mvarNachname As String
Private mvarTelefon As String
Private mvarAdresse As String
Private mvarStadt As String
Private mvarLand As String
Private mvarEmail As String

Dim Ws As Workspace
Dim Db As Database
Dim Rs As Recordset
Dim Feld As Field

Public Enum adKategorie
  adVorname = 0
  adNachname = 1
  adTelefon = 2
  adAdresse = 3
  adStadt = 4
  adLand = 5
  adEmail = 6
End Enum

Public Enum adBewegen
  adVor = 0
  adNach = 1
End Enum

Public Sub Init()
  If Dir(App.Path & "\AdBuch.MDB") = "" Then NeueDatenbank

  Set Ws = DBEngine.Workspaces(0)
  Set Db = Ws.OpenDatabase((App.Path & "\AdBuch.MDB"))
  Set Rs = Db.OpenRecordset("Adressen", dbOpenTable)

  RefreshRs
End Sub

Public Sub NeueDatenbank()
  Dim i As Integer
  Dim Tb As TableDef
  Dim RecS As Recordset
  Dim Felder(6) As String

  Felder(0) = "Vorname"
  Felder(1) = "Nachname"
  Felder(2) = "Telefon"
  Felder(3) = "Adresse"
  Felder(4) = "Stadt"
  Felder(5) = "Land"
  Felder(6) = "Email"

  Set Ws = DBEngine.Workspaces(0)
  Set Db = Ws.CreateDatabase(App.Path & "\AdBuch.MDB", _
                  dbLangGeneral, dbVersion30)

  Set Tb = Db.CreateTableDef("Adressen")

  For i = 0 To 6
    Set Feld = Tb.CreateField(Felder(i), dbText, 200)
    Tb.Fields.Append Feld
  Next i

  Db.TableDefs.Append Tb

  Set Rs = Db.OpenRecordset("Adressen")
  Rs.AddNew
  For i = 0 To 6
    Rs.Fields(i).Value = "Neu"
  Next i
  Rs.Update

  UnInit
End Sub

Public Sub UnInit()
  Db.Close
  Set Feld = Nothing
  Set Rs = Nothing
  Set Db = Nothing
  Set Ws = Nothing
End Sub

Public Sub Speichern()
  Rs.AddNew
  Rs.Fields(0).Value = Vorname
  Rs.Fields(1).Value = Nachname
  Rs.Fields(2).Value = Telefon
  Rs.Fields(3).Value = Adresse
  Rs.Fields(4).Value = Stadt
  Rs.Fields(5).Value = Land
  Rs.Fields(6).Value = Email
  Rs.Update
  Rs.Bookmark = Rs.LastModified
End Sub

Public Sub Bewegen(Richtung As adBewegen)
  Select Case Richtung
    Case adVor
      Rs.MovePrevious
    Case adNach
      Rs.MoveNext
  End Select

  If Rs.EOF Then
    MsgBox "Sie sind am Ende der Einträgeliste.", _
           vbInformation + vbOKOnly, "Information"
    Rs.MovePrevious
  ElseIf Rs.BOF Then
    Rs.MoveNext
    MsgBox "Sie sind am Anfang der Einträgeliste.", _
           vbInformation + vbOKOnly, "Information"
  End If

  RefreshRs
End Sub

Sub RefreshRs()
  If Rs.RecordCount = 0 Then
    MsgBox "Die Datenbank ist leer!", _
           vbInformation + vbOKOnly, "Information"
    frmMain.cmdAnsicht.Enabled = False
    frmMain.cmdSuche.Enabled = False

    frmMain.Show
    frmMain.cmdNeu_Click
    Exit Sub
  End If

  Vorname = Rs.Fields(0).Value
  Nachname = Rs.Fields(1).Value
  Telefon = Rs.Fields(2).Value
  Adresse = Rs.Fields(3).Value
  Stadt = Rs.Fields(4).Value
  Land = Rs.Fields(5).Value
  Email = Rs.Fields(6).Value
End Sub

Public Sub Löschen()
  Rs.Delete

  If Rs.RecordCount = 0 Then
    MsgBox "Der Datenbank ist nun leer. " & vbCrLf & _
           "Sie können jetzt nur noch neue Adressen eingeben.", _
           vbInformation + vbOKOnly, "Information"
    frmMain.cmdAnsicht.Enabled = False
    frmMain.cmdSuche.Enabled = False

    frmMain.cmdNeu_Click
    Exit Sub
  End If

  Bewegen adVor
  RefreshRs
End Sub

Public Function Suche(Kategorie As adKategorie, _
       Begriff As String) As Boolean
  Dim i As Integer

  Rs.MoveFirst
  For i = 0 To Rs.RecordCount - 1
    If Rs.Fields(Kategorie).Value = Begriff Then
      Suche = True
      Exit For
    End If
    Rs.MoveNext
  Next i

  If Suche = True Then
    MsgBox "Die Suche war erfolgreich!", _
       vbInformation + vbOKOnly, "Gefunden"
    RefreshRs
  Else
    MsgBox "Der Suchbegriff wurde nicht gefunden.", _
       vbInformation + vbOKOnly, "Nicht gefunden"
    Rs.MoveFirst
    RefreshRs
    Suche = False
  End If
End Function

Public Property Let Email(ByVal vData As String)
  mvarEmail = vData
End Property

Public Property Get Email() As String
  Email = mvarEmail
End Property

Public Property Let Land(ByVal vData As String)
  mvarLand = vData
End Property

Public Property Get Land() As String
  Land = mvarLand
End Property

'...
'...
'...

Public Property Let Nachname(ByVal vData As String)
    mvarNachname = vData
End Property

Public Property Get Nachname() As String
    Nachname = mvarNachname
End Property

Public Property Let Vorname(ByVal vData As String)
    mvarVorname = vData
End Property

Public Property Get Vorname() As String
    Vorname = mvarVorname
End Property
 
Code im Codebereich der Form frmMain
 
Option Explicit

Dim Adressen As New Adressbuch

Private Sub Form_Load()
  Dim sngLeft As Single
  Dim sngTop As Single

  sngLeft = 120
  sngTop = 1080

  fraSuchen.Move sngLeft, sngTop
  fraNeu.Move sngLeft, sngTop
  fraAnsicht.Move sngLeft, sngTop

  With Me
    .Width = 4785
    .Height = 5760
  End With

  With cmbK
    .AddItem "Vorname"
    .AddItem "Nachname"
    .AddItem "Telefon"
    .AddItem "Adresse"
    .AddItem "Stadt"
    .AddItem "Land"
    .AddItem "Email"

    .ListIndex = 0
  End With

  Adressen.Init
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Adressen.UnInit
  End
End Sub

'----------- Frame "Ansicht der Adressen" -------------
Private Sub cmdAnsicht_Click()
  fraNeu.Visible = False
  fraAnsicht.Visible = True
  fraSuchen.Visible = False

  AdAnsicht
End Sub

Private Sub cmdVor_Click()
  Adressen.Bewegen adVor
  AdAnsicht
End Sub

Private Sub cmdNach_Click()
  Adressen.Bewegen adNach
  AdAnsicht
End Sub

Private Sub cmdL_Click()
  Adressen.Löschen
  AdAnsicht
End Sub

Private Sub cmdPrint_Click()
  RTB.SelPrint Printer.hDC
End Sub

Private Sub AdAnsicht()
  RTB.Text = Adressen.Vorname & " " & Adressen.Nachname & vbCrLf
  RTB.Text = RTB.Text & vbCrLf
  RTB.Text = RTB.Text & "Tel: " & Adressen.Telefon & vbCrLf
  RTB.Text = RTB.Text & "Adresse: " & Adressen.Adresse & ", " & _
             Adressen.Stadt & ", " & Adressen.Land & vbCrLf
  RTB.Text = RTB.Text & vbCrLf
  RTB.Text = RTB.Text & "Email: " & Adressen.Email
End Sub

'----------- Frame "Adresse suchen" -------------------
Private Sub cmdSuche_Click()
  fraNeu.Visible = False
  fraAnsicht.Visible = False
  fraSuchen.Visible = True

  cmbK.SetFocus
End Sub

Private Sub txtS_Change()
  If Len(Trim(txtS.Text)) = 0 Then
    cmdS.Enabled = False
  Else
    cmdS.Enabled = True
  End If
End Sub

Private Sub cmdS_Click()
  If Adressen.Suche(cmbK.ListIndex, txtS.Text) = False Then _
        Exit Sub
  AdAnsicht
  cmdAnsicht_Click
End Sub

'----------- Frame "Neue Adresse" ---------------------
Sub cmdNeu_Click()
  fraNeu.Visible = True
  fraAnsicht.Visible = False
  fraSuchen.Visible = False
  txt(0).SetFocus
End Sub

Private Sub cmdOKN_Click()
  Adressen.Vorname = txt(0).Text
  Adressen.Nachname = txt(1).Text
  Adressen.Telefon = txt(2).Text
  Adressen.Adresse = txt(3).Text
  Adressen.Stadt = txt(4).Text
  Adressen.Land = txt(5).Text
  Adressen.Email = txt(6).Text
  Adressen.Speichern

  cmdAnsicht.Enabled = True
  cmdSuche.Enabled = True

  cmdAnsicht_Click
End Sub
 
Hinweis
Um diesen Tipp ausführen zu können, muss die Microsoft DAO 3.x Object Library als Verweis in das Projekt eingebunden werden.
Weitere Links zum Thema
Bearbeiten von Datensätzen
Datenbank erstellen

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (32,3 kB) Downloads bisher: [ 4837 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Samstag, 25. Juni 2011