home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / ITPJUL90.ZIP / DBASE.PAS next >
Encoding:
Pascal/Delphi Source File  |  1990-06-28  |  8.7 KB  |  319 lines
  1. UNIT dBASE; {$R-}
  2.  
  3. INTERFACE
  4.  
  5. USES Crt;
  6.  
  7. TYPE
  8.  
  9.   DbfFieldType = RECORD
  10.     FdName   : String[10];
  11.     FdType   : Char;
  12.     FdLength : Byte;
  13.     FdDec    : Byte;
  14.   END;
  15.  
  16.   DbfFieldTypeA = ARRAY[0..0] OF DbfFieldType;
  17.  
  18.   DbfFileType = RECORD
  19.     VersionNumber : Byte;
  20.     Update        : ARRAY [1..3] OF Byte;
  21.     NbrRec        : Longint;
  22.     HdrLen        : Integer;
  23.     RecLen        : Word;
  24.     NbrFlds       : Integer;
  25.     FileSize      : Longint;
  26.     FileHndl      : FILE;
  27.     FileName      : String[12];
  28.     FieldStru     : ^DbfFieldTypeA;
  29.   END;
  30.  
  31.   DbfFile = ^DbfFileType;
  32.   CharArray = ARRAY[0..0] OF Char;
  33.   CharPtr = ^CharArray;
  34.  
  35. FUNCTION DbfOpen(FileName : String): DbfFile;
  36. FUNCTION DbfClose(D: DbfFile): Boolean;
  37. FUNCTION DbfReadHdr(D: DbfFile): Byte;
  38. PROCEDURE DbfDispHdr(D: DbfFile);
  39. PROCEDURE Pause;
  40. FUNCTION DbfReadStru(D: DbfFile): Boolean;
  41. PROCEDURE DbfDispStru(D: DbfFile);
  42. PROCEDURE DbfReadRec (RecNum : Longint;
  43.                      D: DbfFile; DbfPtr: CharPtr);
  44. PROCEDURE DbfList(D: DbfFile);
  45. PROCEDURE DbfDispRec(RecNum: Longint;
  46.                      D: DbfFile; DbfPtr: CharPtr);
  47.  
  48. IMPLEMENTATION
  49.  
  50. PROCEDURE Tab(Col:Byte);
  51. BEGIN
  52.    GotoXY(Col MOD 80,WhereY)
  53. END;
  54.  
  55. FUNCTION DbfOpen(FileName : String): DbfFile;
  56. VAR
  57.    D : DbfFile;
  58. BEGIN
  59.    GetMem(D,SizeOf(DbfFileType));
  60.    D^.FileName := FileName;
  61.    Assign(D^.FileHndl, FileName);
  62.    Reset(D^.FileHndl,1);  {Set record length to 1}
  63.    DbfOpen := D;
  64. END;
  65.  
  66. FUNCTION DbfClose(D: DbfFile): Boolean;
  67. BEGIN
  68.   Close(D^.FileHndl);
  69.   FreeMem(D^.FieldStru,
  70.              SizeOf(DbfFieldType)*(D^.NbrFlds+1));
  71.   FreeMem(D,SizeOf(DbfFileType));
  72.   DbfClose := TRUE
  73. END;
  74.  
  75. FUNCTION DbfReadHdr(D: DbfFile): Byte;
  76.  
  77. {------------------------------------------------
  78.  Purpose: Read the Dbase file header information-
  79.           and store in the header record        -                                        -
  80.  -----------------------------------------------}
  81.  
  82. TYPE
  83.    DbfHdrMask = RECORD
  84.       VersionNumber : Byte;
  85.       Update        : ARRAY [1..3] OF Byte;
  86.       NbrRec        : Longint;
  87.       HdrLen        : Integer;
  88.       RecLen        : Integer;
  89.       Reserved      : ARRAY [1..20] OF Char;
  90.    END;
  91. VAR
  92.   Result : Word;
  93.   H : DbfHdrMask;
  94.   I : Byte;
  95. BEGIN
  96.   BlockRead(D^.FileHndl, H, SizeOf(H), Result);
  97.   IF SizeOf(H) = Result THEN
  98.     BEGIN
  99.       WITH D^ DO
  100.         BEGIN
  101.           VersionNumber := H.VersionNumber  AND 7;
  102.           FOR I := 1 TO 3 DO
  103.             Update[I] := H.Update[I];
  104.           NbrRec := H.NbrRec;
  105.           HdrLen := H.HdrLen;
  106.           RecLen := H.RecLen;
  107.           NbrFlds := (H.HdrLen - 33) DIV 32;
  108.           FileSize := H.HdrLen + H.RecLen
  109.                      * H.NbrRec + 1;
  110.           DbfReadHdr := 0;     {No errors        }
  111.           IF VersionNumber <> 3 THEN
  112.             DbfReadHdr := 1    {Not a dBase file }
  113.           ELSE
  114.             IF NbrRec = 0 THEN
  115.               DbfReadHdr := 2  {No records       }
  116.         END {WITH}
  117.     END {IF}
  118.   ELSE
  119.     DbfReadHdr := 3;           {Error reading Dbf}
  120. END; {FUNCTION}
  121.  
  122. PROCEDURE DbfDispHdr(D: DbfFile);
  123.  
  124. {------------------------------------------------
  125.  Display Dbase file header information          -
  126. ------------------------------------------------}
  127. BEGIN
  128.   WITH D^ DO
  129.     BEGIN
  130.       WriteLn('Using ',FileName); WriteLn;
  131.       WriteLn('dBASE Version         :',
  132.                                  VersionNumber:8);
  133.       WriteLn('Number of data records:',
  134.                                         NbrRec:8);
  135.       Write('Date of last update   : ');
  136.       WriteLn(Update[2]:2,'/',Update[3],
  137.                                    '/',Update[1]);
  138.       WriteLn('Header length         :',HdrLen:8);
  139.       WriteLn('Record length         :',RecLen:8);
  140.       WriteLn('Number of fields      :',NbrFlds:8);
  141.       WriteLn('File size             :',FileSize:8)
  142.     END
  143. END;
  144.  
  145. PROCEDURE Pause;
  146. BEGIN
  147.   WriteLn;
  148.   WriteLn('Press Enter to continue');
  149.   ReadLn;
  150. END;
  151.  
  152. FUNCTION DbfReadStru(D: DbfFile): Boolean;
  153.  
  154. {------------------------------------------------
  155.  Purpose: Read the file structure store in the  -
  156.           Dbase file header.                    -
  157. ------------------------------------------------}
  158.  
  159. TYPE
  160.    DbfFieldMask = RECORD
  161.       FdName    : ARRAY [1..11] OF Char;
  162.       FdType    : Char;
  163.       Reserved1 : ARRAY [1..4] OF Char;
  164.       FdLength  : Byte;
  165.       FdDec     : Byte;
  166.       Reserved2 : ARRAY [1..14] OF Char;
  167.    END;
  168. VAR
  169.   Result : Word;
  170.   I, J, HdrTerminator : Byte;
  171.   FldTmp : DbfFieldMask;
  172. BEGIN
  173.   GetMem(D^.FieldStru,
  174.              SizeOf(DbfFieldType)*(D^.NbrFlds+1));
  175.   WITH DbfFieldType(D^.FieldStru^[0]) DO
  176.     BEGIN            {Set up record status field}
  177.       FdName   := 'RecStatus  ';
  178.       FdType   := 'C';
  179.       FdLength := 1;
  180.       FdDec    := 0
  181.     END;
  182.   FOR I := 1 TO D^.NbrFlds DO
  183.     BEGIN
  184.       BlockRead(D^.FileHndl,FldTmp,SizeOf(FldTmp),
  185.                                           Result);
  186.       WITH DbfFieldType(D^.FieldStru^[I]) DO
  187.         BEGIN
  188.           J := POS(#0,FldTmp.FdName);
  189.           IF J <> 0 THEN
  190.             FdName := Copy(FldTmp.FdName,1,J-1);
  191.           FdType   := FldTmp.FdType;
  192.           FdLength := FldTmp.FdLength;
  193.           FdDec    := FldTmp.FdDec
  194.         END
  195.     END;
  196.   {Last Hdr Byte}
  197.   BlockRead(D^.FileHndl,HdrTerminator,1,Result);
  198.   IF HdrTerminator <> 13 THEN
  199.     DbfReadStru := FALSE          {Bad Dbf header}
  200.   ELSE
  201.     DbfReadStru := TRUE
  202. END;
  203.  
  204. PROCEDURE DbfDispStru(D: DbfFile);
  205.  
  206. {-------------------------------------------------
  207.  Purpose: Display the structure of the Dbase file-
  208.           Name, Field Type, Length and number    -
  209.           of decimals if a number                -
  210.  ------------------------------------------------}
  211.  
  212. VAR
  213.    Ty : String[11];
  214.    I : Byte;
  215. BEGIN
  216.   WriteLn;
  217.  
  218.   WriteLn(
  219.   'Field  Field Name  Type        Width     Dec');
  220.  
  221.   FOR I := 1 TO D^.NbrFlds DO
  222.     BEGIN
  223.       WITH DbfFieldType(D^.FieldStru^[I]) DO
  224.         BEGIN
  225.           Write(I:5,'  ',FdName);Tab(20);
  226.           CASE FdType OF
  227.             'C': Ty := 'Character  ';
  228.             'L': Ty := 'Logical    ';
  229.             'N': Ty := 'Number     ';
  230.             'F': Ty := 'Floating Pt';
  231.             'D': Ty := 'Date       ';
  232.             'M': Ty := 'Memo       ';
  233.             ELSE Ty := 'Unknown    '
  234.           END;
  235.           WriteLn(Ty:11,'  ',FdLength:3,'      ',
  236.                                           FdDec:2)
  237.         END;
  238.     END;
  239. Write('   ** Total **'); Tab(32);
  240. WriteLn(D^.RecLen:4)
  241. END;
  242.  
  243. PROCEDURE DbfReadRec (RecNum : Longint;
  244.                      D: DbfFile; DbfPtr: CharPtr);
  245.  
  246. {------------------------------------------------
  247.  Purpose: Read a Dbase record, format date and  -
  248.           logical fields for output             -
  249.  Input  : Array of Field values                 -
  250.  -----------------------------------------------}
  251.  
  252. VAR
  253.   Result      : Word;
  254.   CurrentPos  : Longint;
  255. BEGIN
  256.   CurrentPos := (RecNum-1) * D^.RecLen+D^.HdrLen;
  257.   Seek(D^.FileHndl,CurrentPos);
  258.   BlockRead(D^.FileHndl,DbfPtr^,D^.RecLen,Result)
  259. END;
  260.  
  261. PROCEDURE DbfDispRec(RecNum: Longint;
  262.                      D: DbfFile; DbfPtr: CharPtr);
  263. VAR
  264.   Field              : String;
  265.   I,J                : Integer;
  266.   FPos               : Byte;
  267.   SCol,ColumnSpace   : Byte;
  268. BEGIN
  269.   Write(RecNum:3,'  ');
  270.   FPos := 0;   {Record offset from pointer DbfPtr}
  271.   FOR I := 0 TO D^.NbrFlds DO
  272.     BEGIN
  273.       WITH D^.FieldStru^[I] DO
  274.         BEGIN
  275.           Field := '';
  276.           Move(DbfPtr^[FPos],Field[1],
  277.                                Integer(FdLength));
  278.           Field[0] := Chr(FdLength);
  279.           CASE FdType OF      {Adjust field types}
  280.             'D' : Field := Copy(Field,5,2) + '/' +
  281.                            Copy(Field,7,2) + '/' +
  282.                            Copy(Field,1,4);
  283.             'L' : CASE Field[1] OF
  284.                      'Y','T' : Field := '.T.';
  285.                      'N','F' : Field := '.F.';
  286.                    END;
  287.             ELSE
  288.             END;
  289.           IF FdType <> 'M' THEN
  290.             Write(Field:FdLength,' ');
  291.           FPos := FPos + FdLength   {Set next fld}
  292.         END
  293.     END;
  294.   WriteLn;
  295. END;
  296.  
  297. PROCEDURE DbfList(D: DbfFile);
  298.  
  299. {------------------------------------------------
  300.  Purpose: Main printing routine                 -
  301.  Calls  : ReadDbfRecord                         -
  302.           PrintDbfRecord                        -
  303.  -----------------------------------------------}
  304. VAR
  305.   I : Longint; {Made a longint for seek request}
  306.   DbfPtr : CharPtr;
  307. BEGIN
  308.   WriteLn;
  309.   FOR I := 1 TO D^.NbrRec DO
  310.     BEGIN
  311.       GetMem(DbfPtr, D^.RecLen);
  312.       DbfReadRec(I, D, DbfPtr);
  313.       DbfDispRec(I, D, DbfPtr);
  314.       FreeMem(DbfPtr, D^.RecLen);
  315.     END
  316.   END;
  317.  
  318. END.
  319.