ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/ITPAUG90.ZIP/DBASEII.PAS

Pascal/Delphi Source File | 1990-06-20 | 5.0 KB | 200 lines

PROGRAM MakeDBF;

{*************************************************
* Program: Create a DBF database file            *
*************************************************}

USES Dos,Crt;

FUNCTION DbfCreate(FileNameIn: PathStr): Boolean;

TYPE
   DbfHdrMask = RECORD
      VersionNumber : Byte;
      Update        : ARRAY [1..3] OF Byte;
      NbrRec        : Longint;
      HdrLen        : Integer;
      RecLen        : Integer;
      Reserved      : ARRAY [1..20] OF Char;
   END;

   DbfFieldMask = RECORD
      FdName    : ARRAY [1..11] OF Char;
      FdType    : Char;
      Reserved1 : ARRAY [1..4] OF Char;
      FdLength  : Byte;
      FdDec     : Byte;
      Reserved2 : ARRAY [1..14] OF Char;
   END;

   DbfCreateType = RECORD
      FieldCounter  : Byte;
      FPos          : Integer;
      RecordLength  : Integer;
      Dir           : DirStr;
      Name          : NameStr;
      Ext           : ExtStr;
      LayoutIn      : Text;
      FileNameOut   : PathStr;
      DirInfo       : SearchRec;
      Response      : Char;
      DbfNewOut     : FILE;
      FieldRec      : DbfFieldMask;
      Location      : Word;
      TempString1   : String;
      TempString2   : String;
      Code          : Integer;
      Header        : DbfHdrMask;
      Year,Month,Day,DayOfWeek : Word;
   END;

CONST
  EOH    : Byte = $0D;
  EODbf  : Byte = $1A;

VAR
  D : ^DbfCreateType;

BEGIN

  GetMem(D,SizeOf(D^));
  IF D = NIL THEN BEGIN
    DbfCreate := FALSE;
    Exit
    END;

  FSplit(FileNameIn,D^.Dir,D^.Name,D^.Ext);
  IF Length(D^.Ext) = 0 THEN FileNameIn :=
                              FileNameIn + '.LAY';
  {$I-}
  Assign(D^.LayoutIn,FileNameIn);
  Reset(D^.LayoutIn);
  {$I+}
  IF IOResult <> 0 THEN BEGIN
    WriteLn('Error opening layout file ',
                                      FileNameIn);
    DbfCreate := FALSE;
    FreeMem(D,SizeOf(D^));
    Exit
    END;

  D^.FileNameOut := D^.Dir + D^.Name + '.DBF';
  FindFirst(D^.FileNameOut,AnyFile,D^.DirInfo);
  IF DosError = 0 THEN BEGIN        {File exists}
    WriteLn('File already exists.');
    Write('Replace current ',D^.FileNameOut,
          ' (Y/N)?: ');
    ReadLn(D^.Response);
    IF UpCase(D^.Response) <> 'Y' THEN BEGIN
      FreeMem(D,SizeOf(D^));
      D := NIL;
      DbfCreate := FALSE;
      FreeMem(D,SizeOf(D^));
      Close(D^.LayoutIn);
      Exit
      END;
    END;

  Assign(D^.DbfNewOut,D^.FileNameOut);
  Rewrite(D^.DbfNewOut,1); {Set record size to 1}
  Seek(D^.DbfNewOut,32);   {Beginning of fields }

{First process fields}

  FillChar(D^.FieldRec.Reserved1, 4, 0);
  FillChar(D^.FieldRec.Reserved2,14, 0);

  D^.FieldCounter := 0;
  D^.FPos := 0;
  D^.RecordLength := 0;

  WHILE NOT Eof(D^.LayoutIn) DO BEGIN
    ReadLn(D^.LayoutIn,D^.TempString1);

{Initialize values for next field}

    Inc(D^.FieldCounter);
    Inc(D^.FPos,32);

    FillChar(D^.FieldRec.FdName,11,0);
    D^.Location := Pos(' ',D^.TempString1);
    IF D^.Location < 11 THEN
      Move(D^.TempString1[1],D^.FieldRec.FdName,
           D^.Location-1)
    ELSE
      Move(D^.TempString1[1],D^.FieldRec.FdName,
           10);

    D^.FieldRec.FdType := D^.TempString1[11];

    Move(D^.TempString1[12],D^.TempString2[1],3);
    D^.TempString2[0] := Chr(3);
    {$R-}
    Val(D^.TempString2,D^.FieldRec.FdLength,
        D^.Code);
    {$R+}
    IF D^.Code <> 0 THEN BEGIN
      FreeMem(D,SizeOf(D^));
      D := NIL;
      DbfCreate := FALSE; {Rtn on error}
      Close(D^.LayoutIn);
      Close(D^.DbfNewOut);
      FreeMem(D,SizeOf(D^));
      Exit
      END; {IF}

    D^.TempString2 := '';
    Move(D^.TempString1[15],D^.TempString2[1],2);
    D^.TempString2[0] := Chr(2);
    {$R-}
    Val(D^.TempString2,D^.FieldRec.FdDec,D^.Code);
    {$R+}
    IF D^.Code <> 0 THEN BEGIN
      FreeMem(D,SizeOf(D^));
      D := NIL;
      DbfCreate := FALSE;  {Rtn on error}
      Close(D^.LayoutIn);
      Close(D^.DbfNewOut);
      FreeMem(D,SizeOf(D^));
      Exit
      END; {IF}
    BlockWrite(D^.DbfNewOut,D^.FieldRec,
               SizeOf(D^.FieldRec));
    Inc(D^.RecordLength,D^.FieldRec.FdLength);

    END; {WHILE}

    BlockWrite(D^.DbfNewOut,EOH,1); {End of hdr}
    BlockWrite(D^.DbfNewOut,EODbf,1); {EndOfFile}

{Then set header information}

  WITH D^.Header DO BEGIN
    VersionNumber := $03;
    GetDate(D^.Year,D^.Month,D^.Day,D^.DayOfWeek);
    Update[1] := D^.Year-1900;
    Update[2] := D^.Month;
    Update[3] := D^.Day;
    NbrRec := 0;
    HdrLen := D^.FieldCounter * 32 + 33;
    RecLen := D^.RecordLength + 1;
    END;
  Seek(D^.DbfNewOut,0); {Set to beginning of FILE}
  BlockWrite(D^.DbfNewOut,D^.Header,
             SizeOf(D^.Header));
  Close(D^.LayoutIn);
  Close(D^.DbfNewOut);
  FreeMem(D,SizeOf(D^));
  D := NIL;
  DbfCreate := TRUE
END;


BEGIN
  ClrScr;
  IF DbfCreate('PLANETS.LAY') THEN
    WriteLn('File creation successfull')
  ELSE
    WriteLn('Could not create the dBASE FILE')
END.