[Back to MISC SWAG index]  [Back to Main SWAG index]  [Original]

{
From: <hartkamp@mail.rz.uni-duesseldorf.de>

Might be someone is interested in the code below for writing
.WKS-files.

This special portion of code works with the TOPAZ-toolbox, but you
could use your own access to your data just the same. (Sorry for the
German Identfiers, hope anyone will grasp the contents, otherwise take
a dictionary!)
}

PROCEDURE LotusExport(DBFFile, OutFName : PathStr);
CONST StartSatz     : ARRAY[1..6] OF BYTE = (0,0,2,0,4,4);
      EndeSatz      : ARRAY[1..5] OF BYTE = (1,0,0,0,26);

TYPE  BereichsType  = RECORD
                         Typ, Laenge,
                         VonSpalte, VonZeile,
                         BisSpalte, BisZeile  : INTEGER;
                      END;

      BreitenType   = RECORD
                         Typ, Laenge, Spalte : INTEGER;
                         Breite              : BYTE;
                      END;

      ZahlenType    = RECORD
                         Typ, Laenge    : INTEGER;
                         Format         : BYTE;
                         Spalte, Zeile  : INTEGER;
                         Wert           : DOUBLE; { ONLY DOUBLE WILL DO!!!!!!!!!}
                      END;

      StringType    = RECORD
                         Typ, Laenge    : INTEGER;
                         Format         : BYTE;
                         Spalte, Zeile  : INTEGER;
                         Position       : CHAR;
                         Inhalt         : ARRAY[1..256] OF CHAR;
                      END;

VAR Bereich      : BereichsType;
    Breite       : BreitenType;
    Zahl         : ZahlenType;
    ZKette       : StringType;
    FBez         : StringType;
    RecordNumber : INTEGER;
    RNum         : REAL;
    INum         : INTEGER;
    L            : BOOLEAN;
    h,i,j        : BYTE;
    Zkt          : STRING;
    FName        : STRING;
    OutFile      : FILE;

BEGIN
  SELECT(0);
  USE(DBFFILE, NIL, 0);
  Bereich.Typ         := 6;
  Bereich.Laenge      := 8;
  Bereich.VonSpalte   := 0;
  Bereich.VonZeile    := 0;

  Breite.Typ          := 8;
  Breite.Laenge       := 3;

  Zahl.Typ            := 14;
  Zahl.Laenge         := 13;

  ZKette.Typ          := 15;
  ZKette.Format       := 255;
  ZKette.Position     := CHR(39);

  FBez.Typ            := 15;
  FBez.Laenge         := 17;
  FBez.Format         := 255;
  FBez.Zeile          := 0;
  FBez.Position       := CHR(39);

  IF RecCount > MaxLongInt THEN EXIT;
  Assign(OutFile,OutFName);
  ReWrite(OutFile,1);
  GoTop;
  RecordNumber := 1;
  BlockWrite(OutFile,StartSatz,6);
  Bereich.BisSpalte := FieldCount;
  Bereich.BisZeile  := RecCount;
  BlockWrite(OutFile,Bereich,12);
  FOR i := 1 TO FieldCount DO
    IF FieldType(i) <> 'M' THEN
    BEGIN
      j := FieldLen(i);
      Breite.Spalte := pred(i);
      IF j < 255 THEN Breite.Breite := succ(j)
                 ELSE Breite.Breite := j;
      BlockWrite(OutFile,Breite,7);
    END;
  FOR i := 1 TO FieldCount DO
    IF FieldType(i) <> 'M' THEN
    BEGIN
      FBez.Spalte := pred(i);
      FName := Field(i)+'               ';
      move(FName[1],FBez.Inhalt[1],10);
      FBez.Inhalt[11] := CHR(0);
      BlockWrite(OutFile,FBez,21);
    END;
  REPEAT
    Go(RecordNumber);
    FOR i := 1 TO FieldCount DO BEGIN
      CASE FieldType(i) OF
        'F','N' : BEGIN
                    Zahl.Format := FieldDec(i);
                    Zahl.Spalte := PRED(i);
                    Zahl.Zeile  := RecordNumber;
                    IF FieldDec(i) > 0
                    THEN BEGIN
                       move(FieldAddress(i)^,RNum,6);
                       Zahl.Wert := RNum;
                    END
                    ELSE BEGIN
                       move(FieldAddress(i)^,INum,4);
                       Zahl.Wert := INum;
                    END;
                    BlockWrite(OutFile,Zahl,17);
                  END;
            'C' : BEGIN
                    move(FieldAddress(i)^,Zkt[0],succ(FieldLen(i)));
                    Zkt := Zkt+#0;
                    ZKette.Laenge := Length(Zkt)+6;
                    ZKette.Spalte := PRED(i);
                    ZKette.Zeile  := RecordNumber;
                    move(Zkt[1],ZKette.Inhalt,Length(Zkt));
                    BlockWrite(OutFile,ZKette,ZKette.Laenge+4);
                  END;
            'D' : BEGIN
                    move(FieldAddress(i)^,Zkt[0],succ(FieldLen(i)));
                    IF Zkt[1] = ' ' THEN Zkt := 'keine Angabe';
                    Zkt := Zkt+#0;
                    ZKette.Laenge := Length(Zkt)+6;
                    ZKette.Spalte := PRED(i);
                    ZKette.Zeile  := RecordNumber;
                    move(Zkt[1],ZKette.Inhalt,Length(Zkt));
                    BlockWrite(OutFile,ZKette,ZKette.Laenge+4);
                  END;
            'L' : BEGIN
                    move(FieldAddress(i)^,L,1);
                    IF L THEN Zkt := 'Ja  ' ELSE Zkt := 'Nein';
                    Zkt := Zkt+#0;
                    ZKette.Laenge := Length(Zkt)+6;
                    ZKette.Spalte := pred(i);
                    ZKette.Zeile  := RecordNumber;
                    move(Zkt[1],ZKette.Inhalt,Length(Zkt));
                    BlockWrite(OutFile,ZKette,ZKette.Laenge+4);
                  END;
            'M' : ;
            ELSE BEGIN END;
      END;
    END;
    At(20, 13, LzS(RecordNumber,0)+' Datens�tze kopiert...');
    Inc(RecordNumber);
  UNTIL RecordNumber > RecCount;
  BlockWrite(OutFile,EndeSatz,5);
  Close(OutFile);
  USE('', NIL, 0);
END;

PROCEDURE WKSExport;
VAR  oldSelect  : BYTE;
     DatVar     : PathStr;
     WKSVar     : PathStr;
     d          : DirStr;
     n          : NameStr;
     e          : ExtStr;

BEGIN
  DatVar := '';
  SelectFile('*.DBF','dBase-Datei w�hlen',true);
  FSplit(DatVar, d, n, e);
  WKSVar := d+n+'.WKS';
  PushWindow(16, 11, 60, 18);
  Box(16, 11, 56, 15, DoubleLine + Shadow, '');
  LotusExport(DatVar, WKSVar);
  PopWindow;
  PopUp('Die Tabellendatei ' + FileBase(DatVar) +
        '.WKS'+#13+'  wurde im aktuellen Verzeichnis  '+#13+
        'angelegt...', 'I n f o');
END;

[Back to MISC SWAG index]  [Back to Main SWAG index]  [Original]