Turbo Toolbox/Turbo_Toolbox.iso/1989/05/anwendg/dbdoc.bas

BASIC Source File | 1989-03-17 | 12.3 KB | 328 lines

'* ------------------------------------------------------- *
'*                      DBDOC.BAS                          *
'* Demonstration des Zugriffs auf DBASE III Datenbankfiles *
'* aus Quick Basic. Das Programm gibt den Inhalt einer     *
'* dBase III-Datei auf dem Bildschirm aus.                 *
'*              (c) 1989 G.Born  &  TOOLBOX                *
'* ------------------------------------------------------- *
'*             Compiler : Quick Basic 4.0/4.5              *
'* ------------------------------------------------------- *
'* Wichtiger Hinweis: Einige Anweisungszeilen paßten nicht *
'* in eine Druckzeile, daher sind abgedruckte Zeilen, die  *
'* mit ... enden bzW. beginnen, als eine Basic-Zeile zu    *
'* verstehen. Die ... können ersatzlos gestrichen werden.  *
'* ------------------------------------------------------- *
TYPE header                    '* Header einer DBASE Datei
  version   AS STRING * 1      '* Version 03H oder 83H
  datum     AS STRING * 3      '* Datum JJ MM TT
  records   AS LONG            '* Records in Datenbank
  headerb   AS INTEGER         '* Zahl der Bytes im Kopf
  recordb   AS INTEGER         '* Zahl der Bytes pro Record
  reserve   AS STRING * 20     '* reservierte Bytes
END TYPE

TYPE feld                      '* Feldbeschreibung im Kopf
  fname     AS STRING * 11     '* Feldname 11 Zeichen
  ftyp      AS STRING * 1      '* C N L D M
  dummy1    AS STRING * 4      '* Dummy Feld
  laenge    AS STRING * 1      '* Zahl der Stellen
  komma     AS STRING * 1      '* Zahl der Nachkommastellen
  dummy2    AS STRING * 2      '* reservierte Bytes
  id        AS STRING * 1      '* ID Byte
  dummy3    AS STRING * 11     '* reserviert
END TYPE

DIM kopf(1) AS header          '* Variable für Dateiheader
DIM felder(0 TO 128) AS feld   '* Beschreibung f. 128 Felder
anzahl% = 0                    '* Zahl der Felder

ein% = 1                       '* Kanal für I/O
filename$ = ""                 '* Dateiname

ON ERROR GOTO fehler           '* Fehlerbehandlung

'* --------------  Hauptprogramm  --------------------------

CLS                            '* Clear Screen
PRINT "DBASE III (DBF) DOC        (c) 1989 G.Born & TOOLBOX"
PRINT
INPUT "File    : ", filename$  '* lese Dateiname
PRINT
IF filename$ = "" THEN         '* Leereingabe ?
  PRINT "Der Name der Eingabedatei fehlt"
  END
END IF
'* --------- Bearbeitung der DBASE III Datei ---------------
'* Dabei ist darauf zu achten, daß ein File mit dem ange-  *
'* gegeben Namen existiert, da QBASIC im BINARY-Mode bei   *
'* fehlender Datei eine neue Datei anlegt. Trick: Datei    *
'* erst im INPUT Mode öffnen, falls die Datei nicht vor-   *
'* handen ist, bricht BASIC ab und verzweigt zu Fehler!    *

OPEN filename$ FOR INPUT AS #ein%     '* Datei vorhanden?
CLOSE #ein%                           '* vorhanden -> close
OPEN filename$ FOR BINARY AS #ein%    '* öffne als Binary

CALL GetHeader(ein%)                  '* lese Header

'*   ***  Ausgabe des Headers der DBASE III Datei ***      *
'*  Die Version gibt dabei an, ob intern Memofelder be-    *
'*  nutzt wurden (version = 83H -> Memodatei)              *

PRINT "Header der dBase III-Datei"
PRINT
PRINT "Version      "; HEX$(ASC(kopf(1).version))
PRINT "Datum        "; ASC(MID$(kopf(1).datum, 3, 1)); ".";
PRINT ASC(MID$(kopf(1).datum, 2, 1)); ".";
PRINT ASC(MID$(kopf(1).datum, 1, 1))
PRINT "Records      "; kopf(1).records
PRINT "Header Länge "; kopf(1).headerb
PRINT "Record Länge "; kopf(1).recordb
PRINT
INPUT "Weiter, bitte die <RET> Taste betätigen", tmp$

'* lese und decodiere die Feldbescheibung der dBase III-   *
'* Datei, es sind maximal 128 Felder zulässig              *

CALL GetFieldDef(ein%)              '* lese Feldbeschreibung

PRINT "Feldbeschreibung der Datei "; filename$
PRINT
PRINT "Feldname   │   Typ    │ Stellen │ Kommastellen"
PRINT "───────────┼──────────┼─────────┼─────────────"

FOR i% = 1 TO anzahl%               '* n Felddefinitionen
  PRINT felder(i%).fname; "│";      '* Name des Feldes
  SELECT CASE felder(i%).ftyp       '* gebe Feldtyp aus
    CASE "N"
      PRINT "Numerisch │";
    CASE "C"
      PRINT "Character │";
    CASE "L"
      PRINT "Logical   │";
    CASE "D"
      PRINT "Datum     │";
    CASE "M"
      PRINT "Memo      │";
  END SELECT
  PRINT USING "##"; SPC(4); ASC(felder(i%).laenge);
                                    '* Feldlänge
  PRINT "   │   "; ASC(felder(i%).komma)
                                    '! Nachkommastellen
NEXT i%
PRINT "───────────┴──────────┴─────────┴─────────────"

'* Hinweis: Die Recordlänge ist 1 Byte größer als dies     *
'*          aus den Feldlängen ersichtlich ist, da         *
'*          im ersten Byte des Records die Information     *
'*          für gelöschte Sätze steht (*).                 *

PRINT "Recordlänge in Bytes      "; kopf(1).recordb
PRINT
INPUT "Weiter, bitte die <RET> Taste betätigen", tmp$

'* lese und decodiere die Datensätze der DBASE III Datei   *

PRINT "Datensätze der DBASE III Datei "; filename$
PRINT

'*  Hier wird gezeigt, wie der Inhalt der Datei satzweise  *
'* per FOR Schleife gelesen werden kann.                   *

CALL GotoBottom                '* auf 1. Satz
FOR i% = 1 TO kopf(1).records  '* Schleife über alle Records
  CALL GetRecord(ein%, satz$)  '* lese Satz
  PRINT satz$                  '* dokumentiere Satz
  CALL Skip                    '* nächster Satz
NEXT i%

'* Der Inhalt des letzten Satzes wird verändert und in die *
'* Datenbank zurückgespeichert                             *

satz1$ = " " + "Hallo" + MID$(satz$, 7)  '* ändere Feld 1
CALL PutRecord(ein%, satz1$)             '* speichere Satz

'* Alternativ besteht die Möglichkeit, die Datei satzweise *
'* zu lesen, bis EOF() erreicht ist. Hierfür dient die     *
'* Funktion DBEof().                                       *

PRINT "Lese Datei nochmals"
CALL GotoBottom                        '* auf 1. Satz
CALL DBEof(ein%, status%)              '* EOF erreicht ?
WHILE NOT status%
  CALL GetRecord(ein%, satz$)          '* lese Satz
  CALL Skip                            '* nächster Satz
  CALL DBEof(ein%, status%)            '* EOF erreicht ?
WEND
PRINT "EOF Erreicht"

'* Es wird ein leerer Satz angefügt und mit dem Inhalt des *
'* vorletzten Satzes überschreiben                         *

PRINT "Leersatz anhängen"
CALL AppendBlank(ein%)               '* Leersatz anhängen
CALL PutRecord(ein%, satz$)          '* alten Satz speichern

CLOSE
PRINT "Ende DBDOC"
END

fehler:                      '*  Fehlerbehandlung in DBDOC

IF ERR = 53 THEN
  PRINT "Die Datei "; filename$; " existiert nicht"
ELSE
  PRINT "Fehler : "; ERR; " unbekannt"
  PRINT "Programmabbruch"
END IF
END                          '* MSDOS Exit
RETURN

SUB AppendBlank (handle%)
'* Hänge einen leeren Satz in die DBASE III - Datenbank an *
'* nach dem Aufruf steht der Schreiblesezeiger auf diesem  *
'* Satz, d.h. PutRecord kann direkt Daten speichern.       *

SHARED kopf() AS header            '* Kopfdaten
SHARED felder() AS feld, anzahl%   '* Feldbeschreibung
SHARED recnr&                      '* Byte Feldanfang

  satz$ = STRING$(kopf(1).recordb, " ") '* Buffer mit Blanks
  recnr& = kopf(1).headerb + 1 + ...
                      ...(kopf(1).recordb * kopf(1).records)

  PUT #handle%, recnr&, satz$       '* schreibe Buffer in DB
  satz$ = CHR$(&H1A)                '* create EOF()
  PUT #handle%, , satz$             '* EOF anhängen

  kopf(1).datum = CHR$(VAL(MID$(DATE$, 9, 2))) + ...
               ...CHR$(VAL(MID$(DATE$, 1, 2))) + ...
               ...CHR$(VAL(MID$(DATE$, 4, 2)))        '* Tag
  kopf(1).records = kopf(1).records + 1
                                    '* Korrektur Recordzahl
  PUT #handle%, 1, kopf(1)          '* Header aktualisieren
END SUB

SUB DBEof (handle%, ende%)
'*  Prüfe, ob EOF() der Datenbank erreicht ist

SHARED kopf() AS header                '* Kopfdaten
SHARED felder() AS feld, anzahl%       '* Feldbeschreibung
SHARED recnr&                          '* Byte Feldanfang

  IF recnr& >= kopf(1).headerb + 1 + (kopf(1).recordb * ...
              ...kopf(1).records) THEN
   ende% = -1                           '* True
  ELSE
   ende% = 0                            '* False
  END IF
END SUB

SUB GetFieldDef (handle%)
'* lese und decodiere die Feldbescheibung der dBase III-   *
'* Datei, es sind maximal 128 Felder zulässig              *

SHARED kopf() AS header              '* Kopfdaten
SHARED felder() AS feld, anzahl%     '* Feldbeschreibung
SHARED recnr&                        '* Schreib-/Lesezeiger

  anzahl% = ((kopf(1).headerb - 1) / 32) - 1
                                 '* Zahl der Felder
  SEEK #handle%, 33              '* setze Zeiger auf 1. Feld
  FOR i% = 1 TO anzahl%          '* lese n Felddefinitionen
    GET #handle%, , felder(i%)   '* lese Definition Feld
    IF EOF(handle%) THEN         '* Fehler abfangen?
      PRINT "Fehler: Ende Feldbeschreibung erreicht "
      END
    END IF
  NEXT i%
     '* prüfe, ob nächstes Byte das Header Ende signalisiert
  headend$ = " "                   '* Check Header Ende
  GET #handle%, , headend$         '* lese Zeichen
  IF headend$ <> CHR$(&HD) THEN    '* Ende = 0DH
    PRINT "Fehler: Header Ende nicht gefunden"
    END
  END IF
  recnr& = SEEK(handle%)           '* merke Feldanfang
END SUB

SUB GetHeader (handle%)
'* Die Routine liest den Dateiheader ein und prüft, ob es  *
'* sich um eine gültige dBase III-Datei handelt. Im Fehler-*
'* fall terminiert das Programm mit einer Meldung.         *
SHARED kopf() AS header

GET #handle%, 1, kopf(1)            '* lese Kopf der Datei
IF EOF(handle%) THEN                '* dBase Datei ?
  PRINT "Keine dBase III-Datei, da (EOF) erreicht"
  END
END IF
vers% = ASC(kopf(1).version)        '* decode Versionscode
IF vers% <> &H83 AND vers% <> &H3 THEN
  PRINT "Keine dBase III-Datei, da Header (Code) falsch"
  PRINT "Code : "; HEX$(ASC(kopf(1).version))
  END
ELSE
  IF vers% = &H2 THEN               '* dBase II-Header
    PRINT "dBase II-Header"
    END
  END IF
END IF
END SUB

SUB GetRecord (handle%, buffer$)
'* lese einen Satz aus der dBase III-Datenbank und         *
'* gebe das Ergebnis in buffer$ zurück. Die Daten sind     *
'* als ASCII - Text in der Datenbank abgelegt.             *
SHARED kopf() AS header              '* Kopfdaten
SHARED felder() AS feld, anzahl%     '* Feldbeschreibung
SHARED recnr&                        '* Byte Feldanfang

  buffer$ = SPACE$(kopf(1).recordb)  '* Buffer auf Satzlänge
  GET #handle%, recnr&, buffer$      '* lese Satz in Buffer
END SUB

SUB GotoBottom
'* Positioniere den Schreib- / Lesezeiger auf Satz 1.      *
SHARED kopf() AS header                '* Kopfdaten
SHARED felder() AS feld, anzahl%       '* Feldbeschreibung
SHARED recnr&                          '* Byte Feldanfang

  recnr& = kopf(1).headerb + 1         '* erster Satz
END SUB

SUB PutRecord (handle%, buffer$)
'* Schreibe einen Satz in die dBase III - Datenbank.       *
'* Die Daten sind als ASCII - Text im Puffer, geordnet     *
'* nach Feldern, abzulegen. Achtung: Die Bufferlänge       *
'* muß gleich der Recordlänge in DBASE sein !!!            *
'* Der Inhalt des Puffers wird an der aktuellen Stelle     *
'* in die Datenbank abgespeichert.                         *
SHARED kopf() AS header                '* Kopfdaten
SHARED felder() AS feld, anzahl%       '* Feldbeschreibung
SHARED recnr&                          '* Byte Feldanfang

  IF LEN(buffer$) <> kopf(1).recordb THEN
    PRINT "Fehler: Satzlänge falsch -> soll : ";
    PRINT kopf(1).recordb; " ist : "; LEN(buffer$)
  END IF
  PUT #handle%, recnr&, buffer$     '* schreibe Buffer in DB

  kopf(1).datum = CHR$(VAL(MID$(DATE$, 9, 2))) + ...
               ...CHR$(VAL(MID$(DATE$, 1, 2))) + ...
               ...CHR$(VAL(MID$(DATE$, 4, 2)))
  PUT #handle%, 2, kopf(1).datum    '* Datum aktualisieren
END SUB

SUB Skip
'* Positioniere den Schreib-/Lesezeiger einen Satz weiter  *
SHARED kopf() AS header                '* Kopfdaten
SHARED felder() AS feld, anzahl%       '* Feldbeschreibung
SHARED recnr&                          '* Byte Feldanfang

  recnr& = recnr& + kopf(1).recordb    '* nächster Satz
END SUB

'* ------------------------------------------------------- *
'*                  Ende von DBDOC.BAS                     *