Lotus Script Code zum einbinden in eigene Anwendungen.

 ' Anwendungsbeispiel:
 ' Dim db As New dBase("c:\db.dbf")
 ' Call db.Go(1)
  
 ' While Not db.isEof
 '   Print db.GetField("Feldname")
 '   db.Skip(1)
 ' Wend
  
 ' (C) 2005 Rolf Holighaus - www.rhacl.de
 Public Const DBASE_READWRITE = 0
 Public Const DBASE_READONLY = 1
 
 Type DatabaseStruct
  DatabaseName As String
  HeadLen As Long
  RecordLen As Long
  CurrentRecord As Long
  Eof As Variant
  Bof As Variant
 End Type
 
 Type fieldStruct
  FieldName As String
  Len As Integer
  Dec As Integer
  Type As String
  nPos As Long ' Die Position innerhalb des Buffers
 End Type
 
 Class dBase
  Private Database As DatabaseStruct
  Private fileNumber As Integer
  Private fieldArray() As fieldStruct
  Private Buffer As String
  Private isDelete As Variant
  Private numberOfFields As Integer
  Private nPosB As Long
  Private OutputBinaryFlag As Integer
  Private OutputBinaryLeftByte As Long
  Private lExists As Variant
  Private lIsOpen As Variant
  Private readWriteFlag As Integer
  
  Function isEof As Variant
   isEof = Database.Eof
  End Function
  
  Function isBof As Variant
   isBof = Database.Bof
  End Function
  
  Function Pack As Variant
   Dim hasPacked As Variant
   Dim packFile As Integer
   Dim packFileName As String
   Dim i As Integer
   Dim packBuffer As String
   Dim nRecNos As Long
   
   hasPacked = False
   
   ' Die Datendatei erneut öffnen als gesperrte Datei
   On Error Goto ErrorHandle
   Close fileNumber
   Open Database.DatabaseName For Binary Access Read Write Lock Read Write As fileNumber
   
   ' Einen eindeutigen Temporären Dateinamen vergeben
   For i = 1 To 10000
    packFileName = "_pck"+Trim(Cstr(i))+".tmp"
    If Dir$(packFileName) = "" Then
     Exit For
    End If
   Next i
   
   packFile = Freefile()
   
   Open packFileName For Binary Access Read Write Lock Read Write As packFile
   
   ' Kopieren des Headers incl Feldbeschreibung
   packBuffer = Inputbp$(Database.HeadLen ,fileNumber)
   Call OutputBinaryString(packFile,packBuffer,Database.HeadLen)
   
   ' Alle nicht gelöschten Datensätze kopieren
   Go(1)
   nRecNos = 0
   While Not isEof()
    If Not isDeleted() Then
     Call OutputBinaryString(packFile,Buffer,Database.RecordLen)
     nRecNos = nRecNos + 1
    End If
    Call Skip(1)
   Wend
   
   ' Dateiendekennzeichen anhängen
   Call OutputBinaryString(packFile,Chr(26),1)
   
   Call SetRecNoInHeader(packFile,nRecNos)
   
   
   Close packFile
   Close fileNumber
   lIsOpen = False
   
   ' Die gepackte Datei Kopieren
   Stop 
   Kill Database.DatabaseName
   Name packFileName As Database.Databasename
   
   ' Datenbank wieder normal öffnen
   lIsOpen = OpenThisDatabase()
   Go(1)
   
   Pack = hasPacked
   Exit Function
   
 ErrorHandle:
   Pack = False
   Messagebox "Fehler: (" & Err & ") " & Error,,"Fehler"
   ' Datenbank wieder normal öffnen
   lIsOpen = OpenThisDatabase()
   Exit Function
  End Function
  
  Private Sub setRecNoInHeader(fileNumber As Integer,nRecno As Long)
   Put fileNumber,5,nRecNo
  End Sub
  
  
  Sub Go(nRec As Long)
   If nRec < 1 Then
    Buffer = Space(Database.RecordLen)
    Database.CurrentRecord = 0
    Database.Bof = True
    Exit Sub
   End If
   
   Call SetToRecord(nRec)
   
   If Eof(fileNumber) Then
    Buffer = Space(Database.RecordLen)
    Database.CurrentRecord = 0
    Database.Eof = True
   Else
    Database.CurrentRecord = nRec
    Database.Eof = False
    ReadBuffer
   End If
  End Sub
  
  Function DBName As String
   DBName = Database.DatabaseName
  End Function
  
  Function GetFieldAsString(fieldName As String) As String
   Dim uFieldName As String
   Dim fieldBuffer As String
   Dim hasFound As Variant
   
   hasFound = False
   uFieldname = Ucase(fieldName)
   Forall sField In FieldArray
    If sField.FieldName = uFieldName Then
     fieldBuffer = Mid(Buffer,sField.nPos+1,sField.Len)
     hasFound = True
     Select Case sField.Type
     Case "M"
      GetFieldAsString = ""
      Exit Forall
     Case Else
      GetFieldAsString = fieldBuffer
      Exit Forall
     End Select    
    End If
   End Forall
   If Not hasFound Then
    GetFieldAsString = ""
   End If
  End Function
  
  Function GetField(fieldName As String) As Variant
   Dim uFieldName As String
   Dim fieldBuffer As String
   Dim hasFound As Variant
   Dim J As Integer
   Dim M As Integer
   Dim D As Integer
   Dim fieldValue As Variant
   
   fieldValue = ""
   hasFound = False
   uFieldname = Ucase(fieldName)
   Forall sField In FieldArray
    If sField.FieldName = uFieldName Then
     fieldBuffer = Mid(Buffer,sField.nPos+1,sField.Len)
     hasFound = True
     Select Case sField.Type
     Case "C"
      fieldValue = fieldBuffer
      Exit Forall
     Case "N"
      fieldValue = Val(fieldBuffer)
      Exit Forall
     Case "L"
      If Instr("YT",Ucase(fieldBuffer)) > 0 Then
       fieldValue = True
      Else
       fieldValue = False
      End If  
      Exit Forall
     Case "D"
      fieldValue = fieldBuffer
      J = Val(Left(fieldBuffer,4))
      If J < 1950 Then
       J = J + 100
      End If
      M = Val(Mid(fieldBuffer,5,2))
      D = Val(Mid(fieldBuffer,7,2))
      
      fieldValue = Datenumber(J,M,D)
      
      Exit Forall
     Case "M"
      fieldValue = ""
      Exit Forall
     Case Else
      fieldValue = fieldBuffer
      Exit Forall
     End Select    
    End If
   End Forall
   GetField = fieldValue
  End Function
  
  Private Sub ReadBuffer
   On Error Goto ErrorHandle
   Buffer = Input$(Database.RecordLen,fileNumber)
   Exit Sub
 ErrorHandle:
   Buffer = Space(Database.RecordLen)
   Database.Eof = True
   Database.CurrentRecord = 0
   Exit Sub
  End Sub
  
  Private Sub SetToRecord(nRec As Long)
   ' Seek fileNumber,Database.HeadLen + ((nRec - 1) * Database.RecordLen) + 4
   Seek fileNumber,Database.HeadLen + ((nRec - 1) * Database.RecordLen) + 1
  End Sub
  
  Function IsDeleted() As Variant
   If Left(Buffer,1) = "*" Then
    IsDeleted = True
   Else
    IsDeleted = False
   End If
  End Function
  
  Sub DeleteRecord
   Dim nRec As Long
   If Database.CurrentRecord > 0 And Not Database.Eof And Not Database.Bof Then
    
    ' Auf den aktuellen Satz positionieren
    Call SetToRecord(Database.CurrentRecord)
    
    nRec = Seek(fileNumber)
    
    ' Der Satzzeiger steht jetzt vor der löschmarkierung
    ' Wegschreiben der Löschmarkierung
    If LockRecord Then
     Call OutputBinary(fileNumber,"*")
     UnlockRecord
    End If
   End If
  End Sub
  
  Sub UnDeleteRecord
   If Database.CurrentRecord > 0 And Not Database.Eof And Not Database.Bof Then
    
    ' Auf den aktuellen Satz positionieren
    Call SetToRecord(Database.CurrentRecord)
    
    ' Der Satzzeiger steht jetzt vor der löschmarkierung
    ' Wegschreiben der Löschmarkierung
    If LockRecord Then
     Call OutputBinary(fileNumber," ")
     UnlockRecord
    End If
    
    
   End If
  End Sub
  
  Function LockRecord As Variant
   Dim lCurrPos As Long
   
   On Error Goto ErrorHandle
   Call SetToRecord(Database.CurrentRecord)
   lCurrPos = Seek(fileNumber)
   Lock fileNumber,lCurrPos To lCurrPos + Database.RecordLen
   LockRecord = True
   Exit Function
   
 ErrorHandle:
   LockRecord = False
   Exit Function
   
  End Function
  
  Function UnlockRecord As Variant
   Dim lCurrPos As Long
   
   On Error Goto ErrorHandle
   Call SetToRecord(Database.CurrentRecord)
   lCurrPos = Seek(fileNumber)
   Unlock fileNumber,lCurrPos To lCurrPos + Database.RecordLen
   UnlockRecord = True
   Exit Function
   
 ErrorHandle:
   UnlockRecord = False
   Exit Function
  End Function
  
  Function Skip(nRecs As Long)
   Call Go(Database.CurrentRecord + nRecs)
  End Function
  
  Function RecNo() As Long
   RecNo = Database.CurrentRecord
  End Function
  
  Function Exists As Variant
   Exists = lExists
  End Function
  
  Function IsOpen As Variant
   IsOpen = lIsOpen
  End Function
  
  Private Sub OutputBinaryString(fileHandle As Integer,sByteString As String,iLen As Long)
   Dim i As Integer
   Dim anByte As String
          ' Schreibt an der aktuellen Position einen String in eine Datei
   Dim nLen As Integer
   For i = 1 To iLen
    anByte = Mid(sByteString,i,1)
    Call OutputBinary(fileHandle,anByte)
   Next
  End Sub
  
  
  Private Sub OutputBinary(fileHandle As Integer,anByte As String)
       ' Schreibt an der aktuellen Position einer Binary Datei ein Zeichen
   Dim outInt As Integer
   Dim nPos As Long
   Dim leftByte As Long
   Dim rightByte As Long
   
   ' Die aktuelle Position feststellen
   nPos = Seek(fileHandle)
   
   If nPos <= 1 Then
    leftByte = Asc(anByte) 
    rightByte = 0
   Else
    Seek fileHandle,nPos - 1
    ' Das linke Byte holen als Unicode
    leftByte = Uni(Inputb(1,fileHandle))
    rightByte = Asc(anByte)
    Seek fileHandle,nPos - 1
   End If
   
   If rightByte > 127 Then
    outInt = leftByte + (rightByte * 256) - 65536
   Else
    outInt = leftByte + (rightByte * 256)
   End If
   
   Put fileHandle,,outInt
   Seek fileHandle,nPos + 1
   
  End Sub 
  
  Private Function OpenThisDatabase() As Variant
   Dim lOk As Variant
   lOk = False
   
   On Error Goto ErrorHandle
   
   If lIsOpen Then
    Close fileNumber
   Else
    If fileNumber = -1 Then
     fileNumber = Freefile()
    End If
   End If
   
   If ReadWriteFlag = DBASE_READWRITE Then
    Open Database.DatabaseName For Binary Access Read Write Shared As fileNumber
   Else
    Open Database.DatabaseName For Binary Access Read Shared As fileNumber
   End If
   
   OpenThisDatabase = True
   Exit Function
   
 ErrorHandle:
   OpenThisDatabase = False
   lIsOpen = False
   Messagebox "Fehler: (" & Err & ") " & Error,,"Fehler"
   Exit Function
  End Function
  
  Sub CloseDatabase
   On Error Goto ErrorHandle
   
   If lIsOpen Then
    Close fileNumber
    lIsOpen = False
   End If
   
   Exit Sub
 ErrorHandle:
   Messagebox "Fehler: (" & Err & ") " & Error,,"Fehler"
   Exit Sub
  End Sub
  
  ' Kunstruktor
  Sub New(fName As String, newReadWriteFlag As Integer)
   Dim Nr1 As Integer
   Dim Nr256 As Integer
   Dim tmpBuffer As Variant
   Dim i As Integer
   Dim nPos As Integer
   
   lExists = False
   lIsOpen = False
   fileNumber = -1
   
   If Dir$(fName) = "" Then
    lExists = False
    Exit Sub
   Else
    lExists = True
   End If
   
   
   Database.DatabaseName = Ucase(fName)
   Database.Eof = False
   Database.Bof = False
   
   On Error Goto ErrorHandle
   
   readWriteFlag = newReadWriteFlag
   
   lIsOpen = OpenThisDatabase()
   
   ' Die Länge des Headers lesen
   Seek fileNumber,8+1
   Nr1 = Uni(Inputb(1,fileNumber))  
   Nr256 = Uni(Inputb(1,fileNumber))
   Database.HeadLen = Nr1 + (Nr256 * 256)
   
   
   ' Die Recordlänge lesen
   Nr1 = Uni(Inputb(1,fileNumber))
   Nr256 = Uni(Inputb(1,fileNumber))
   Database.RecordLen = Nr1 + (Nr256 * 256)
   
   ' Die Anzahl der Felder ist Größe des Headers - Globaler Header - 2   / 32 Bytes je Feld
   numberOfFields = (Database.HeadLen - 32 - 2) / 32
   
   ' Die Feldstruktur einlesen
   ' Auf den ersten FeldEintrag setzen
   Seek fileNumber,32 + 1
   nPosB = 1
   Redim fieldArray(numberOfFields - 1) As fieldStruct
   For i = 0 To numberOfFields - 1
    fieldArray(i).nPos = nPosB
    ' Feldname
    tmpBuffer = Trim(Ucase(Input(11,fileNumber)))
    nPos = Instr(tmpBuffer,Chr(0))
    If nPos > 0 Then
     fieldArray(i).FieldName = Left(tmpBuffer,nPos-1)
    Else
     fieldArray(i).FieldName = tmpBuffer
    End If
    fieldArray(i).type = Ucase(Input$(1,fileNumber))
    tmpBuffer = Inputb(4,fileNumber) ' feld Addresse wird übergangen
    fieldArray(i).Len = Uni(Inputb(1,fileNumber))
    fieldArray(i).Dec = Uni(Inputb(1,fileNumber))
    tmpBuffer = Inputb(14,fileNumber) ' Reservierte Bytes werder übergangen
    nPosB = nPosB + fieldArray(i).Len
   Next
   tmpBuffer = Inputb(2,fileNumber)
   
   Go(1)
   
   Exit Sub
   
 ErrorHandle:
   Close fileNumber
   lIsOpen = False
   Messagebox "Fehler: (" & Err & ") " & Error,,"Fehler"
   Exit Sub
  End Sub 
  
  ' Destruktor
  Sub Delete
   CloseDatabase
  End Sub 
 End Class