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

Pascal/Delphi Source File | 1990-09-04 | 11.5 KB | 384 lines

UNIT WriteDbf; {$R-}

{***************************************************************
**   UNIT   : WriteDBF.PAS                                    **
**   PURPOSE: Write records to dBASE III+/IV DBF files        **
****************************************************************}

INTERFACE

USES Dos,Crt;

{-------------------------------------------------
- Create types and define variables              -
-------------------------------------------------}

TYPE

  DbfFieldType = RECORD
    FdName   : String[10];
    FdType   : Char;
    FdLength : Byte;
    FdDec    : Byte;
  END;

  DbfFieldTypeA = ARRAY[0..0] OF DbfFieldType;

  DbfFileType = RECORD
    VersionNumber : Byte;
    Update        : ARRAY [1..3] OF Byte;
    NbrRec        : Longint;
    HdrLen        : Integer;
    RecLen        : Word;
    NbrFlds       : Integer;
    FileSize      : Longint;
    FileHndl      : FILE;
    FileName      : String[12];
    FieldStru     : ^DbfFieldTypeA;
  END;

  DbfFile = ^DbfFileType;
  CharArray = ARRAY[0..0] OF Char;
  CharPtr = ^CharArray;

FUNCTION DbfOpen(FileName : String): DbfFile;
FUNCTION DbfClose(D: DbfFile): Boolean;
FUNCTION DbfReadHdr(D: DbfFile): Byte;
PROCEDURE DbfDispHdr(D: DbfFile);
PROCEDURE Pause;
FUNCTION DbfReadStru(D: DbfFile): Boolean;
FUNCTION DbfInputRec(D: DbfFile): CharPtr;
PROCEDURE DbfWriteRec (RecNum: Longint; D: DbfFile; P: CharPtr);

{***************************************************************}
                        IMPLEMENTATION
{***************************************************************}

PROCEDURE Tab(Col:Byte);
BEGIN
  GotoXY(Col MOD 80,WhereY)
END;

{-------------------------------------------------
- Name   : HeapFunc                              -
- Purpose: Provide heap error handling           -
- Input  : Size of memory request to heap        -
- Output : Error return code                     -
-------------------------------------------------}

{$F+} FUNCTION HeapFunc(Size: Word) : Integer; {$F-}
BEGIN
  HeapFunc := 1  {Return Nil when can not complete request}
END;

{-------------------------------------------------
- Name   : DbfOpen                               -
- Purpose: Manage open DBF file tasks            -
- Input  : Filename stored in a string           -
- Output : Pointer to a new DbfFileType record   -
-------------------------------------------------}

FUNCTION DbfOpen(FileName : String): DbfFile;
VAR
   D : DbfFile;
BEGIN
   GetMem(D,SizeOf(DbfFileType));
   D^.FileName := FileName;
   Assign(D^.FileHndl, FileName);
   Reset(D^.FileHndl,1);             {Set record length to 1}
   DbfOpen := D;
END;

{-------------------------------------------------
- Name   : DbfClose                              -
- Purpose: Closes an open dBASE file             -
- Input  : Pointer to record of DbfFileType      -
- Output : True upon file close                  -
-------------------------------------------------}

FUNCTION DbfClose(D: DbfFile): Boolean;
BEGIN
  Close(D^.FileHndl);
  FreeMem(D^.FieldStru, SizeOf(DbfFieldType)*(D^.NbrFlds+1));
  FreeMem(D,SizeOf(DbfFileType));
  DbfClose := TRUE
END;

{-------------------------------------------------
- Name   : DbfReadHdr                            -
- Purpose: Read the Dbase file header info       -
-          and store it in the header record     -
- Input  : Pointer to record of DbfFileType      -
- Output : Result code from reading header       -
-------------------------------------------------}

FUNCTION DbfReadHdr(D: DbfFile): Byte;

TYPE
   DbfHdrMask = RECORD
      VersionNumber : Byte;
      Update        : ARRAY [1..3] OF Byte;
      NbrRec        : Longint;
      HdrLen        : Integer;
      RecLen        : Integer;
      Reserved      : ARRAY [1..20] OF Char;
   END;
VAR
  Result : Word;
  H : DbfHdrMask;
  I : Byte;
BEGIN
  Seek(D^.FileHndl,0);              {Move ptr to file beginning}
  BlockRead(D^.FileHndl, H, SizeOf(H), Result); {Read hdr info}
  IF SizeOf(H) = Result THEN
    BEGIN
      WITH D^ DO
        BEGIN
          VersionNumber := H.VersionNumber  AND 7;
          FOR I := 1 TO 3 DO
            Update[I] := H.Update[I];
          NbrRec := H.NbrRec;
          HdrLen := H.HdrLen;
          RecLen := H.RecLen;
          NbrFlds := (H.HdrLen - 33) DIV 32;
          FileSize := H.HdrLen + H.RecLen * H.NbrRec + 1;
          DbfReadHdr := 0;                  {No errors        }
          IF VersionNumber <> 3 THEN
            DbfReadHdr := 1                 {Not a dBase file }
          ELSE
            IF NbrRec = 0 THEN
              DbfReadHdr := 2               {No records       }
        END {WITH}
    END {IF}
  ELSE
    DbfReadHdr := 3;                        {Error reading Dbf}
END; {FUNCTION}

{-------------------------------------------------
- Name   : DbfDispHdr                            -
- Purpose: Display the header info to the screen -
- Input  : Pointer to a record of DbfFileType    -
-------------------------------------------------}

PROCEDURE DbfDispHdr(D: DbfFile);

BEGIN
  WITH D^ DO
    BEGIN
      WriteLn('Using ',FileName); WriteLn;
      WriteLn('dBASE Version         :', VersionNumber:8);
      WriteLn('Number of data records:', NbrRec:8);
      Write('Date of last update   : ');
      WriteLn(Update[2]:2,'/',Update[3], '/',Update[1]);
      WriteLn('Header length         :', HdrLen:8);
      WriteLn('Record length         :', RecLen:8);
      WriteLn('Number of fields      :', NbrFlds:8);
      WriteLn('File size             :', FileSize:8)
    END
END;

{-------------------------------------------------
- Name   : Pause                                 -
- Purpose: Print msg and prompt use for keypress -
-------------------------------------------------}

PROCEDURE Pause;

BEGIN
  WriteLn;
  WriteLn('Press Enter to continue');
  ReadLn;
END;

{-------------------------------------------------
- Name   : DbfReadStru                           -
- Purpose: Read file structure & store in dBASE  -
-          file header record                    -
- Input  : Pointer to record of DbfFileType      -
- Output : Boolean success response              -
-------------------------------------------------}

FUNCTION DbfReadStru(D: DbfFile): Boolean;

TYPE
  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;

VAR
  Result : Word;
  I, J, HdrTerminator : Byte;
  FldTmp : DbfFieldMask;

BEGIN

  GetMem(D^.FieldStru, SizeOf(DbfFieldType)*(D^.NbrFlds+1));

 {Set up record status field}

  WITH DbfFieldType(D^.FieldStru^[0]) DO BEGIN
    FdName   := 'RecStatus  ';
    FdType   := 'C';
    FdLength := 1;
    FdDec    := 0
    END;

  FOR I := 1 TO D^.NbrFlds DO BEGIN
    BlockRead(D^.FileHndl,FldTmp,SizeOf(FldTmp), Result);
    WITH DbfFieldType(D^.FieldStru^[I]) DO BEGIN
      J := POS(#0,FldTmp.FdName);
      IF J <> 0 THEN FdName := Copy(FldTmp.FdName,1,J-1);
      FdType := FldTmp.FdType;
      Write(FdType);
      FdLength := FldTmp.FdLength;
      FdDec    := FldTmp.FdDec
      END
    END;

  {Last Hdr Byte}

  BlockRead(D^.FileHndl,HdrTerminator,1,Result);
  IF HdrTerminator <> 13 THEN
    DbfReadStru := FALSE          {Bad Dbf header}
  ELSE
    DbfReadStru := TRUE
END;

{-------------------------------------------------
- Name   : DbfInputRec                           -
- Purpose: Get a record from user                -
- Input  : Pointer to DbfFileType record         -
- Output : Pointer to buffer to write to file    -
-------------------------------------------------}

FUNCTION DbfInputRec(D: DbfFile): CharPtr;
VAR
  S : String[255];
  DbfPtr : CharPtr;
  FPos,TempPos : Integer;
  I : Integer;

BEGIN

  GetMem(DbfPtr,D^.RecLen);    {Reserve mem for Record contents}
  IF DbfPtr = NIL THEN BEGIN   {Memory allocation error        }
    DbfInputRec := NIL;
    Exit
    END;

  FillChar(DbfPtr^,D^.RecLen,' ');      {Pad record with spaces}

  ClrScr;
  GotoXY(33,1);
  WriteLn('Enter records'); WriteLn;
  Write('Field Name    Type                Length');
  WriteLn('  Decimals  - Enter Value');
  WriteLn;

  FPos := 1; {Set current position in rec to write to next field}
  FOR I := 1 TO D^.NbrFlds DO BEGIN

  {Input the value from the user}

    WITH DbfFieldType(D^.FieldStru^[I]) DO BEGIN
      IF FdType = 'M' THEN BEGIN
         END
      ELSE BEGIN
        Write(FdName);Tab(15);
        Write(FdType);
        CASE FdType OF
          'C' : Write('Character       ');
          'N' : Write('Numeric         ');
          'F' : Write('Floating Point  ');
          'L' : Write('Logical         ');
          'D' : Write('Date (YYYYMMDD) ')
          ELSE
        END;
        Write(FdLength:8,FdDec:8);Tab(54);Write('<');
        FillChar(S[1], FdLength, ' ');
        S[0] := Chr(FdLength);
        Write(S,'>');
        GotoXY(WhereX-FdLength-1,WhereY);
        ReadLn(S);

        {Truncate if too long}

        IF Length(S) > FdLength THEN S := Copy(S,1,FdLength);

  {Put the field contents into the buffer, adjust position you
   begin writing to make field value left or right justified}

        CASE FdType OF                                 {Justify }
          'C','L','D': TempPos := FPos;                {   Left }
          ELSE TempPos := FPos + FdLength - Length(S)  {or Right}
          END;  {CASE}
        Move(S[1],DbfPtr^[TempPos],Length(S));
        END;  {IF}

        Inc(FPos,FdLength)       {set to beginning of next field}

      END  {WITH}
    END;  {FOR}
    DbfInputRec := DbfPtr
  END; {BEGIN}

{-------------------------------------------------
- Name   : DbfWriteRec                           -
- Purpose: Write a dBASE record                  -
- Input  : Record number to write                -
-          Pointer to DbfFileType record         -
-          Pointer to record buffer to write     -
- Output :                                       -
-------------------------------------------------}

PROCEDURE DbfWriteRec (RecNum: Longint; D: DbfFile; P: CharPtr);

VAR
  Offset,RecPos : Longint;
  Appending : Boolean;
  EofChar : Char;
  Y,M,Day,Dow : Word;
  Date : String[3];
BEGIN
  WITH D^ DO BEGIN
    IF RecNum = -1 THEN BEGIN                  {Appending RECORD}
      Offset := NbrRec * RecLen;          {Calc offset into data}
      Inc(NbrRec);                   {Add a record for Appending}
      Seek(FileHndl,4); {Update the hdr field value # of records}
      BlockWrite(FileHndl,NbrRec,Integer(SizeOf(NbrRec)));
      Appending := TRUE
      END
    ELSE BEGIN                        {Replacing existing RECORD}
      Offset := (RecNum - 1) * RecLen;    {Calc offset into data}
      Appending := FALSE
      END;
    RecPos := Offset + HdrLen;        {Calc offset into FILE}
    Seek(FileHndl,RecPos);          {Position to record location}
    BlockWrite(FileHndl,P^,RecLen);
    FreeMem(P,RecLen);

    IF Appending THEN BEGIN    {Write EOF character if Appending}
      EofChar := Chr(26);
      BlockWrite(FileHndl,EofChar,1)
      END;

    GetDate(Y,M,Day,Dow);{Update last update date in file header}
    {Create Date}
    Date := Chr(Lo(Y-1900)) + Chr(Lo(M)) + Chr(Lo(Day));
    Seek(FileHndl,1);
    BlockWrite(FileHndl,Date[1],3);

    WriteLn('Record written and file updated'); WriteLn;

    END  {WITH}
  END;  {DbfWriteRec}

  BEGIN
  HeapError := @HeapFunc;         {Initialize HeapError FUNCTION}
END.