Startseite / Tipps / VB 5/6-Tipp 0585: Arbeiten mit lokalen Recordsets unter ADO

VB 5/6-Tipp 0585: Arbeiten mit lokalen Recordsets unter ADO

 von Peter K. Sauer

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'--------- Anfang Projektdatei ADO_Adress_Local.vbp ---------
' Es muss ein Verweis auf 'Microsoft ActiveX Data Objects 2.5 Library' gesetzt werden.
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (MsComCtl.ocx)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Toolbar "Toolbar1"
' Steuerelement: Listenanzeigesteuerungselement "lvwAdress"

'-------------------------------------------------------------------------
'
'     ADO_Adress_Local     (c) peter.k.sauer@web.de
'-------------------------------------------------------------------------
'     eine Adressverwaltung über einen lokalen Recordset
'     völlig ohne Datenbank aber mit Datenbanktechnik
'-------------------------------------------------------------------------
'     einbinden Projekt -> Verweise  Microsoft ActiveX Data Objects 2.x
'-------------------------------------------------------------------------

Option Explicit

'Class für Recordset Adress local
Private cAdress As clsADOAdressLocal

Dim TbLine1 As Line
Dim TbLine2 As Line

Private Sub Form_Activate()

   Static IniDone As Boolean
   Dim FileName As String
   Dim Msg() As String
   
      If IniDone Then
         Exit Sub
      End If
      
      IniDone = True
      Me.Refresh
      
      'Recordset local einlesen oder anlegen
      FileName = App.Path
      If Right(FileName, 1) <> "\" Then
         FileName = FileName & "\"
      End If
      FileName = FileName & "Adress.rs"
      
      'übergeben an Class
      cAdress.FileNameRecordSet = FileName
      
      If Not cAdress.ExistFile(FileName) Then
         ReDim Msg(4)
         Msg(0) = "Hallo,"
         Msg(2) = "die Adressdatei " & FileName
         Msg(4) = "existiert noch nicht, jetzt anlegen ?" & Space(10)
         
         If vbNo = MsgBox(Join(Msg, vbCrLf), vbYesNo Or vbQuestion, "Adressdatei") Then
            Unload Me
            Exit Sub
         End If
         
         If Not cAdress.RsCreate Then
            Unload Me
            Exit Sub
         End If
      Else
         If Not cAdress.RsOpen Then
            Unload Me
            Exit Sub
         End If
      End If
      
      'Listview Header ausgeben
      cAdress.ListViewHeader lvwAdress
      lvwAdress.Visible = True
      lvwAdress.Refresh
      
      'Zeilen ausgeben
      cAdress.ListViewLines lvwAdress
End Sub

Private Sub Form_Load()

      Me.Width = 12000
      Me.Height = 8250
      If Screen.Width > Me.Width Then
         Me.Top = (Screen.Height - Me.Height) / 2
         Me.Left = (Screen.Width - Me.Width) / 2
      Else
         Me.Top = 0
         Me.Left = 0
      End If
      
      'Class activieren
      Set cAdress = New clsADOAdressLocal
      
      'Toolbar einrichten
      With Toolbar1
         .Style = tbrFlat
         .Buttons.Add , "Show", "Show", tbrDefault
         .Buttons.Add , "New", "New", tbrDefault
         .Buttons.Add , "Change", "Change", tbrDefault
         .Buttons.Add , "Delete", "Delete", tbrDefault
         .Buttons.Add , , , tbrSeparator
         .Buttons.Add , "Exit", "Exit", tbrDefault
      End With
      
      'Trennlinie unter Toolbar
      Set TbLine1 = Me.Controls.Add("VB.Line", "TbLine1", Me)
      Set TbLine2 = Me.Controls.Add("VB.Line", "TbLine2", Me)
      
      With TbLine1
         .Y1 = Toolbar1.Height
         .Y2 = .Y1
         .X1 = 0
         .BorderColor = vbInactiveTitleBar
         .Visible = True
      End With
      
      With TbLine2
         .Y1 = TbLine1.Y1 + 15
         .Y2 = .Y1
         .X1 = 0
         .BorderColor = vbWindowBackground
         .Visible = True
      End With
      
      'Listview Eigenschaften
      With lvwAdress
         .View = lvwReport
         .LabelEdit = lvwManual
         .HideSelection = False
         .FullRowSelect = True
         .Visible = False
      End With
End Sub

Private Sub Form_Resize()
      If Me.WindowState = vbMinimized Then
         Exit Sub
      End If
      On Error Resume Next
      
      TbLine1.X2 = Me.ScaleWidth
      TbLine2.X2 = TbLine1.X2
      
      With lvwAdress
         .Top = Toolbar1.Height + 90
         .Left = 0
         .Width = Me.ScaleWidth
         .Height = Me.ScaleHeight - .Top
      End With
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
   
      Select Case Button.Key
         Case "Exit"
            Unload Me
         Case "Delete"
            RecordDelete
         Case "New"
            RecordNew Button.Key
         Case "Show", "Change"
            RecordUpdate Button.Key
         Case Else
      End Select
End Sub

Private Sub RecordNew(ButtonKey As String)
'neue Adresse

   Dim Frm As Form
   
      Set Frm = New frmAdress
      Set Frm.cAdress = cAdress
      Frm.RecordsetState = ButtonKey
      Load Frm
      Frm.Top = Me.Top + (Me.Height - Frm.Height) / 2
      Frm.Left = Me.Left + (Me.Width - Frm.Width) / 1.2
      Frm.Show vbModal, Me
      
      If Frm.UpdateDone Then
         'neuen Stand anzeigen
         lvwAdress.ListItems.Clear
         cAdress.ListViewLines lvwAdress
      End If
            
      Set Frm = Nothing
End Sub

Private Sub RecordUpdate(ButtonKey As String)
'bestehende Adresse zeigen oder ändern
            
   Dim Frm As Form
   Dim i As Long
   Dim ID As Long
   
      If lvwAdress.ListItems.Count > 0 Then
        
         'Zeiger im Recordset auf Adresse stellen
         ID = Val(lvwAdress.SelectedItem.Key)
         
         If cAdress.RecordFindID(ID) Then
         
            'Instanz laden
            Set Frm = New frmAdress
            
            'aktuellen Stand der Class übergeben
            Set Frm.cAdress = cAdress
            
            'Action Show oder Change übergeben
            Frm.RecordsetState = ButtonKey
            Load Frm
            
            'positionieren in Abhängigkeit von Parentform
            Frm.Top = Me.Top + (Me.Height - Frm.Height) / 2
            Frm.Left = Me.Left + (Me.Width - Frm.Width) / 1.2
            
            'modal anzeigen
            Frm.Show vbModal, Me
            
            'wurde geändert
            If Frm.UpdateDone Then
               
               'neuen Stand anzeigen
               i = lvwAdress.SelectedItem.Index
               lvwAdress.ListItems.Clear
               cAdress.ListViewLines lvwAdress
               
               'geändertes Item markieren
               lvwAdress.ListItems(i).Selected = True
            End If
            Set Frm = Nothing
         End If
      End If

End Sub

Private Sub RecordDelete()
'aktuelle Adresse löschen

   Dim Msg() As String
   Dim ID As Long
   
      ID = Val(lvwAdress.SelectedItem.Key)
      ReDim Msg(2)
      Msg(0) = "soll die Adresse No " & ID
      Msg(2) = "wirklich gelöscht werden ?"
      If vbNo = MsgBox(Join(Msg, vbCrLf), vbYesNo Or vbQuestion, "Delete") Then
         Exit Sub
      End If
      
      'im Recordset löschen
      If Not cAdress.RecordDelete(ID) Then
         Exit Sub
      End If
      
      'aus Listview löschen
      With lvwAdress
         .ListItems.Remove (.SelectedItem.Index)
      End With
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'--- Anfang Klasse "clsADOAdressLocal" alias clsADOAdressLocal.cls  ---

'------------------------------------------------------------------
'
'     clsADOAdressLocal (c) peter.k.sauer@web.de
'
'     Adressverwaltung unter ADO über lokalen Recordset ohne Access
'------------------------------------------------------------------
'     Project -> Verweise Microsoft ActiveX Data Objects 2.x
'------------------------------------------------------------------

Option Explicit

'Recorset für Adressen
Public Rs As ADODB.Recordset

'Dateiname für Rs Adress
Private mvarFileNameRecordSet As String

'Veränderungen im Recordset ??
Private mvarIsChanged As Boolean

'Automatische Sicherung bei Änderungen
Private mvarAutoSave As Boolean

Public Property Let AutoSave(ByVal vData As Boolean)
    mvarAutoSave = vData
End Property

Public Property Get AutoSave() As Boolean
    AutoSave = mvarAutoSave
End Property

Public Property Let IsChanged(ByVal vData As Boolean)
    mvarIsChanged = vData
End Property

Public Property Get IsChanged() As Boolean
    IsChanged = mvarIsChanged
End Property

Public Property Let FileNameRecordSet(ByVal vData As String)
    mvarFileNameRecordSet = vData
End Property

Public Property Get FileNameRecordSet() As String
    FileNameRecordSet = mvarFileNameRecordSet
End Property

Public Function RsCreate() As Boolean
'Recordset einmalig anlegen


      On Error Goto Fehler
      With Rs.Fields
         .Append "AD_ID", adInteger
         .Append "AD_Name", adVarChar, 35
         .Append "AD_VorName", adVarChar, 35
         .Append "AD_Land", adVarChar, 3
         .Append "AD_Plz", adVarChar, 5
         .Append "AD_Ort", adVarChar, 35
         .Append "AD_Strasse", adVarChar, 35
         .Append "AD_Geburtsdatum", adDate
         .Append "AD_Telefon", adVarChar, 20
         .Append "AD_Fax", adVarChar, 20
         .Append "AD_Handy", adVarChar, 20
      End With
      Rs.Open
      Rs.Save FileNameRecordSet
      
      IsChanged = True
      RsCreate = True
      Exit Function
      
Fehler:
      FehlerAnzeige Err.Number, Err.Description, "RsCreate"
End Function

Public Function RsOpen() As Boolean
'lokalen Recordset laden

      On Error Goto Fehler
      Rs.Open FileNameRecordSet
      RsOpen = True
      Exit Function
      
Fehler:
      FehlerAnzeige Err.Number, Err.Description, "RsOpen"
End Function

Public Function RsSave() As Boolean
'lokalen Recordset auf Platte schreiben

      On Error Goto Fehler
      Rs.Save FileNameRecordSet
      
Fehler:
      If (Err.Number = 0) Or (Err.Number = 58) Then
         RsSave = True
         Exit Function
      End If
      FehlerAnzeige Err.Number, Err.Description, "RsSave"
End Function
Public Function RecordAdd(txtFields As Object) As Boolean

   Dim i As Long
   
      On Error Goto Fehler
      Rs.AddNew
      For i = 0 To Rs.Fields.Count - 1
         If Len(txtFields(i)) > 0 Then
            If Rs.Fields(i).Type = adDate Then
               'Datumseingabe überprüfen
               If Not IsDate(txtFields(i).Text) Then
                  FehlerAnzeigeDatum txtFields(i).Text
                  Exit Function
               End If
            End If
            Rs.Fields(i).Value = txtFields(i).Text
         End If
      Next
      Rs.Update
      RecordAdd = True
      IsChanged = True
      Exit Function
      
Fehler:
      FehlerAnzeige Err.Number, Err.Description, "RecordAdd"
End Function

Public Function RecordUpdate(txtFields As Object) As Boolean
'einen Recordset updaten

   Dim i As Long
   
      On Error Goto Fehler
      For i = 1 To Rs.Fields.Count - 1
         If Len(txtFields(i)) > 0 Then
            If Rs.Fields(i).Type = adDate Then
               'Datumseingabe überprüfen
               If Not IsDate(txtFields(i).Text) Then
                  FehlerAnzeigeDatum txtFields(i).Text
                  Exit Function
               End If
            End If
            Rs.Fields(i).Value = txtFields(i).Text
         End If
      Next
      Rs.Update
      RecordUpdate = True
      IsChanged = True
      Exit Function
      
Fehler:
      FehlerAnzeige Err.Number, Err.Description, "RecordUdate"
End Function

Public Function RecordDelete(ID As Long) As Boolean
'einen Record löschen

   Dim Anzahl As Long

      On Error Goto Fehler
      Rs.Filter = "AD_ID = " & ID
      If Rs.RecordCount = 0 Then
         Rs.Filter = adFilterNone
         Exit Function
      End If
      Rs.Delete
      Rs.Filter = adFilterNone
      
      RecordDelete = True
      IsChanged = True
      Exit Function
      
Fehler:
      FehlerAnzeige Err.Number, Err.Description, "RecordDelete"
End Function

Public Function RecordNextId() As Long
'ermittelt die nächste ID_Nr

   Dim ID As Long
   
      If Rs.RecordCount > 0 Then
         Rs.Sort = "AD_ID Asc"
         Rs.MoveLast
         ID = Rs.Fields("AD_ID").Value
      End If
      RecordNextId = ID + 1
End Function

Public Function RecordFindID(ID As Long) As Boolean
'sucht in einem Recordset nach einer ID

      Rs.Filter = adFilterNone
      Rs.MoveFirst
      Rs.Find "AD_ID = " & ID
      If Not Rs.EOF Then
         RecordFindID = True
      End If
End Function

Private Sub Class_Initialize()
'Recordset local aktivieren

      Set Rs = New ADODB.Recordset
End Sub

Private Sub Class_Terminate()
'Recordset eliminieren

      If Not Rs Is Nothing Then
         If Rs.State = adStateOpen Then
            'bei Änderung automatische Sicherung
            If IsChanged Then
               'sichern
               RsSave
            End If
            Rs.Close
         End If
         Set Rs = Nothing
      End If
End Sub

Private Sub FehlerAnzeige(ErrNumber As Long, ErrDescription As String, _
                         Optional Titel As String = "")

   Dim Msg As String
   
      Msg = "Fehler " & ErrNumber & vbCrLf & vbCrLf & _
            ErrDescription
      MsgBox Msg, vbCritical, Titel
End Sub

Private Sub FehlerAnzeigeDatum(sDatum As String)

      FehlerAnzeige 4711, sDatum & " ist kein gültiges Datum", "Datumsfehler"
End Sub

Public Function ExistFile(FileName As String, _
                          Optional Hidden As Boolean = False) _
                          As Boolean
'prüft die Existenz einer Datei

      If Hidden Then
         If Len(Dir(FileName, vbHidden)) > 0 Then
            ExistFile = True
         End If
      Else
         If Len(Dir(FileName)) > 0 Then
            ExistFile = True
         End If
      End If
End Function

Public Function ListViewHeader(lvw As ListView) As Boolean
'ListView activieren

   Dim i As Long
   
      For i = 0 To Rs.Fields.Count - 1
         lvw.ColumnHeaders.Add , , Mid(Rs.Fields(i).Name, 4)
      Next
End Function

Public Function ListViewLines(lvw As ListView) As Boolean
'Listview ausgeben

   Dim i As Long
   Dim Li As ListItem
   
      If Rs.RecordCount = 0 Then
         Exit Function
      End If
      Rs.MoveFirst
      Do While Not Rs.EOF
         Set Li = lvw.ListItems.Add
         Li.Text = Rs.Fields(0).Value & vbNullString
         Li.Key = Rs.Fields("AD_ID").Value & "x"
         For i = 1 To Rs.Fields.Count - 1
            If Rs.Fields(i).Type = adDate Then
               If Rs.Fields(i).Value <> 0 Then
                  Li.SubItems(i) = Rs.Fields(i).Value & vbNullString
               End If
            Else
               Li.SubItems(i) = Rs.Fields(i).Value & vbNullString
            End If
         Next
         Rs.MoveNext
      Loop
End Function
'--- Ende Klasse "clsADOAdressLocal" alias clsADOAdressLocal.cls  ---
'----- Anfang Formular "frmAdress" alias frmAdress.frm  -----
' Steuerelement: Schaltfläche "cmdOk"
' Steuerelement: Schaltfläche "cmdCancel"
' Steuerelement: Textfeld "txtAdress" (Index von 0 bis 0)
' Steuerelement: Beschriftungsfeld "lblAdress" (Index von 0 bis 0)

Option Explicit

'Class Adress, wird übergeben von Main
Public cAdress As clsADOAdressLocal

'Show, New, Change
Private mvarRecordsetState As String

'Veränderungen im Recordset vorgenommen
Private mvarUpdateDone As Boolean

Public Property Let UpdateDone(ByVal vData As Boolean)
    mvarUpdateDone = vData
End Property

Public Property Get UpdateDone() As Boolean
    UpdateDone = mvarUpdateDone
End Property

Public Property Let RecordsetState(ByVal vData As String)
    mvarRecordsetState = vData
End Property

Public Property Get RecordsetState() As String
    RecordsetState = mvarRecordsetState
End Property

Private Sub cmdCancel_Click()
      Unload Me
End Sub

Private Sub cmdOk_Click()

      If RecordsetState = "New" Then
         'neue Adresse einfügen
         
         If Not cAdress.RecordAdd(txtAdress) Then
            Exit Sub
         End If
         UpdateDone = True
         
      ElseIf RecordsetState = "Change" Then
         'Adresse updaten
         
         If Not cAdress.RecordUpdate(txtAdress) Then
            Exit Sub
         End If
         UpdateDone = True
      End If
      Unload Me
End Sub

Private Sub Form_Load()

   Dim i As Long
   
      'die Beschriftung
      Select Case RecordsetState
         Case "Show": Me.Caption = "Adresse zeigen"
         Case "New": Me.Caption = "neue Adresse anlegen"
         Case "Change": Me.Caption = "Adresse ändern"
         Case Else
      End Select
   
      'Label und Textfelder einrichten und ggf füllen
      With cAdress
         For i = 0 To .Rs.Fields.Count - 1
            'Label einrichten
            
            If i > 0 Then
               Load lblAdress(i)
            End If
            lblAdress(i).Caption = Mid(.Rs.Fields(i).Name, 4)
            lblAdress(i).Top = lblAdress(0).Top + i * 450
            lblAdress(i).Visible = True
               
            'Textfelder einrichten
            If i > 0 Then
               Load txtAdress(i)
               txtAdress(i).Text = ""
               txtAdress(i).MaxLength = 0
            End If
            If InStr(1, "Show Change", RecordsetState, vbTextCompare) > 0 Then
              
               'Inhalt anzeigen
               If .Rs.RecordCount > 0 Then
                  If .Rs.Fields(i).Type = adDate Then
                     If .Rs.Fields(i).Value <> 0 Then
                        txtAdress(i).Text = .Rs.Fields(i).Value
                     End If
                  Else
                     txtAdress(i).Text = .Rs.Fields(i).Value
                     Debug.Print txtAdress(i).Text
                  End If
               End If
            End If
            
            'Position Top
            txtAdress(i).Top = txtAdress(0).Top + i * 450
            
            'die maximale Länge anhand des Feldtyps
            Select Case .Rs.Fields(i).Type
               Case adVarChar
                  txtAdress(i).MaxLength = .Rs.Fields(i).DefinedSize
               Case adDate
                  txtAdress(i).MaxLength = 10
               Case adInteger
                  txtAdress(i).MaxLength = 10
               Case Else
                  txtAdress(i).MaxLength = 15
            End Select
            
            'Länge einstellen
            txtAdress(i).Width = 120 + txtAdress(i).MaxLength * 105
            
            'sichtbar machen
            txtAdress(i).Visible = True
            If InStr(1, "Show", RecordsetState, vbTextCompare) > 0 Then
              
               'bei Anzeigen keine Änderung möglich
               txtAdress(i).Locked = True
            End If
            txtAdress(i).TabIndex = i
         Next
         txtAdress(0).Enabled = False
         
         'bei New ermitteln der nächsten ID
         i = 0
         If RecordsetState = "New" Then
            txtAdress(0).Text = .RecordNextId
         End If
      End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
      Set cAdress = Nothing
End Sub
'------ Ende Formular "frmAdress" alias frmAdress.frm  ------
'---------- Ende Projektdatei ADO_Adress_Local.vbp ----------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Rs.Open FileNameRecordSet

Rs.Open FileNameRecordSet, , , , adCmdFile