Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
     (lpvDest As Any, _
      lpvSource As Any, _
      ByVal cbCopy As Long)
 
Private Type Adr
    SatzNummer   As String * 10
    Name         As String * 75
    Vorname      As String * 50
    Strasse      As String * 75
    PLZ          As String * 10
    Wohnort      As String * 75
    Land         As String * 50
    Telefon_P    As String * 15
    Telefon_G    As String * 15
    Handy        As String * 15
    Fax          As String * 15
    MailAddresse As String * 125
    HomePage     As String * 255
    Sonstiges    As String * 255
    Bemerkungen  As String * 255
    Formular     As String * 10
End Type
 
Private Addressen As Adr
 
Private Sub SaveAll(Optional newSatzNr As Long)
   Dim F As Byte
   Dim DSNr As Long
   Dim i As Integer
 
   If txt(0).Text = "" Then
       MsgBox "Speichern des Datensatzes ist nicht möglich.", vbExclamation, _
         "Fehler"
       Exit Sub
   End If
 
   For i = 0 To 15
      With Addressen
        Select Case i
           Case 0
              .SatzNummer = txt(i) & ";0;"
           Case 1
              .Name = txt(i).Text & ";1;"
           Case 2
              .Vorname = txt(i).Text & ";2;"
           Case 3
              .Strasse = txt(i).Text & ";3;"
           Case 4
              .PLZ = txt(i).Text & ";4;"
           Case 5
              .Wohnort = txt(i).Text & ";5;"
           Case 6
              .Land = txt(i).Text & ";6;"
           Case 7
              .Telefon_P = txt(i).Text & ";7;"
           Case 8
              .Telefon_G = txt(i).Text & ";8;"
           Case 9
              .Handy = txt(i).Text & ";9;"
           Case 10
              .Fax = txt(i).Text & ";10;"
           Case 11
              .MailAddresse = txt(i).Text & ";11;"
           Case 12
              .HomePage = txt(i).Text & ";12;"
           Case 13
              .Sonstiges = txt(i).Text & ";13;"
           Case 14
               .Bemerkungen = txt(i).Text & ";14;"
           Case 15
               .Formular = txt(i).Text & ";15;"
        End Select
      End With
   Next
 
   F = FreeFile()
   On Error GoTo FileError
   Open "Adressen.TXT" For Random As #F Len = Len(Addressen)
   On Error GoTo 0
     If newSatzNr > 0 Then
        DSNr = newSatzNr
     Else
        DSNr = Val(txt(0).Text)
     End If
     'Datensatz speichern
     Put #F, DSNr, Addressen
   Close #F
   Exit Sub
 
FileError:
   MsgBox "Die Adressdatei konnte nicht gefunden oder geöffnet werden!", _
     vbExclamation, "Dateifehler"
End Sub
 
Private Function ConvertUDT(oUDT As Adr) As String
    Dim S As String
    S = Space(Len(Addressen))
    CopyMem ByVal S, oUDT, Len(Addressen)
    ConvertUDT = S
End Function
 
Private Sub LoadDS(ByVal sNr As Long)
   Dim vErg As Variant
   Dim F As Byte
   Dim n As Integer
   Dim i As Long
   Dim S As String
 
   'Felder leeren
   For i = 0 To 15
      txt(i).Text = ""
   Next
 
   F = FreeFile()
   On Error GoTo FileError
   Open "Adressen.TXT" For Random As #F Len = Len(Addressen)
   On Error GoTo 0
       Get #F, sNr, Addressen
   Close #F
 
   'Datensatz als gelöscht markiert?
   If Trim(Addressen.Formular) = "DELETE" Then Exit Sub
   S = ConvertUDT(Addressen)
   vErg = Split(S, ";") 'na Trickreich was :-)
   For i = 0 To UBound(vErg) - 1 Step 2
      txt(n) = Trim(vErg(i))
      n = n + 1
   Next
 
   Exit Sub
FileError:
   MsgBox "Fehler beim Öffnen der Datei.", vbExclamation, "Dateifehler"
End Sub
 
Private Sub cmdDel_Click()
   Dim jN As Variant
   If List1.ListIndex < 0 Then
      MsgBox "Sie müssen zuerst einen Datensatz aus der Liste auswählen.", _
        vbExclamation, "Fehler"
      Exit Sub
   End If
   'Obligatorische Frage für die Ober-DAU's
   jN = MsgBox("Wollen Sie die markierte Addresse wirklich löschen?", _
     vbQuestion + vbYesNo, "WARNUNG")
   If jN = vbNo Then Exit Sub
   DeleteDS List1.ItemData(List1.ListIndex), List1.ListIndex
End Sub
 
Private Sub cmdNew_Click()
   Dim F As Byte
   For i = 0 To 15
      txt(i).Text = ""
   Next
   F = FreeFile()
   On Error GoTo FileError
   Open "Adressen.TXT" For Random As #F Len = Len(Addressen)
      If LOF(F) > 1 Then
         txt(0).Text = (LOF(F) / Len(Addressen)) + 1
      Else
         txt(0).Text = 1
      End If
   Close #F
   Exit Sub
FileError:
   MsgBox "Fehler beim Öffnen der Adressdatei.", vbExclamation, "Fehler"
End Sub
 
Private Sub cmdSave_Click()
   SaveAll
End Sub
 
Private Sub cmdSearch_Click()
    Dim b As Byte, C As Byte
    For i = 0 To 15
       If txt(i).Text <> "" Then
          b = b + 1
          C = i
       End If
    Next
    If b = 0 Then
       MsgBox "Sie müssen einen Suchbegriff eingeben.", vbInformation, "Suchen" & _
         "abgebrochen"
       Exit Sub
    End If
    If b > 1 Then
       MsgBox "Bitte nur einen Suchbegriff eingeben!", vbInformation, "Suchen" & _
         "abgebrochen"
       Exit Sub
    End If
    If Not FindDS(txt(C).Text) Then
       MsgBox "Keinen Datensatz gefunden.", vbInformation, "Suchergebnis:"
    End If
End Sub
 
Private Sub Form_Load()
     Dim F As Byte
     Dim DSNr As Long, i As Long, Nr As Long
     Dim n As String, v As String
 
     For i = 0 To 15
       txt(i).Text = ""
     Next
 
     F = FreeFile()
     On Error GoTo FileError
     Open "Adressen.TXT" For Random As #F Len = Len(Addressen)
     On Error Resume Next
         'Satzanzahl ermitteln
         If LOF(F) > 1 Then
            DSNr = (LOF(F) / Len(Addressen))
         Else
            'Satz mit X keine DS vorhanden ;-(
            Close #F
            Exit Sub
         End If
         n = "": v = "": Nr = 0
         For i = 1 To DSNr
            Get #F, i, Addressen
            If Trim(Addressen.Formular) <> "DELETE" Then
               n = Left(Addressen.Name, InStr(Addressen.Name, ";") - 1)
               v = Left(Addressen.Vorname, InStr(Addressen.Vorname, ";") - 1)
               Nr = Val(Left(Addressen.SatzNummer, InStr(Addressen.SatzNummer, _
                 ";") - 1))
               List1.AddItem n & vbTab & v
               List1.ItemData(List1.ListCount - 1) = Nr
            End If
         Next
     Close #F
     Exit Sub
 
FileError:
     MsgBox "Fehler beim Öffnen der Datei.", vbExclamation, "Dateifehler"
End Sub
 
Private Sub List1_Click()
   LoadDS List1.ItemData(List1.ListIndex)
End Sub
 
Private Function FindDS(ByVal sBegriff As String) As Boolean
   Dim F As Byte
   Dim DSNr As Long, i As Long, n As Long
   Dim S As String
   Dim m As String
 
   FindDS = False
   F = FreeFile()
   On Erroro GoTo FileError
   Open "Adressen.TXT" For Random As #F Len = Len(Addressen)
   On Error GoTo 0
 
       'Anzahl DS Ermitteln
       If LOF(F) > 1 Then
          DSNr = (LOF(F) / Len(Addressen))
       Else
          Close #F
          Exit Function
       End If
 
       For i = 1 To DSNr
          Get #F, i, Addressen
          If Trim(Addressen.Formular) <> "DELETE" Then
             S = ConvertUDT(Addressen)
             n = InStr(S, sBegriff)
             If n > 0 Then
               'Position checken
               n = InStr(n, S, ";") + 1
               m = Mid(S, n)
               n = InStr(m, ";")
               F = Val(Left(m, n - 1))
               If txt(F).Text <> "" Then
                  FindDS = True
                  If FoundDS(Addressen) Then
                      Exit Function
                  End If
               End If
             End If
          End If
       Next
    Close #F
    Exit Function
 
FileError:
    MsgBox "Die Datei konnte nicht geöffnet werden.", vbExclamation, _
      "Dateifehler"
End Function
 
Private Function FoundDS(oAdr As Adr) As Boolean
    Dim jN As Variant
    FoundDS = False
 
    jN = MsgBox("Es konnte ein Datensatz gefunden werden." & vbCrLf & _
                "Den Datensatz <" & _
                Trim(oAdr.Name) & " " & Trim(oAdr.Vorname) & "> laden?", _
                vbQuestion + vbYesNo, "Datensatz gefunden ...")
    If jN = vbYes Then LoadDS Val(Left(Addressen.SatzNummer, InStr( _
      Addressen.SatzNummer, ";") - 1))
    jN = MsgBox("Beenden (JA) oder weitersuchen (NEIN)?", _
               vbQuestion + vbYesNo, "Weitersuchen?")
    If jN = vbYes Then FoundDS = True
End Function
 
Private Sub DeleteDS(ByVal sNr As Long, ByVal lNr As Long)
    Dim F As Byte
    On Error GoTo FileError
    F = FreeFile()
    Open "Adressen.TXT" For Random As #F Len = Len(Addressen)
       Get #1, sNr, Addressen
       Addressen.Formular = "DELETE"
       Put #1, sNr, Addressen
    Close #1
 
    List1.RemoveItem lNr
    Exit Sub
 
FileError:
    MsgBox "Die Adressendatei konnte nicht geöffnet werden.", vbExclamation, _
      "Dateifehler"
End Sub