home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / w3_prog / db3tpwdl.arj / DB3DEMDL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-09-13  |  6.1 KB  |  248 lines
  1. { Simple program to test the DB3 DLL DBase file open functions }
  2. { Requires db3dll.dll in windows path                          }
  3. { Written by Nigel Salt 1991 - apologies for PASCAL it is not   }
  4. {                              my first language!               }
  5. PROGRAM db3demdl;
  6. {$F+}
  7. USES WinTypes, WinProcs,WObjects, Strings, db3dlun;
  8. {db3dlun imports the routines from the DLL}
  9.  
  10. TYPE
  11.  
  12. TDB3App=object(TApplication)
  13.   procedure InitMainWindow; virtual;
  14. end;
  15. PDB3Win=^TDB3Win;
  16. TDB3Win=object(TWindow)
  17.   procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  18. end;
  19.  
  20.  
  21. {*************************************************************}
  22. VAR
  23. {*************************************************************}
  24.   testdb: dbfRecord;
  25.   testdbflds: ARRAY[1..3] OF _FieldRecord;
  26.   testdbfldptr: _dFields;
  27.   testdbdata: String;
  28.   Iresult: Integer;
  29.   DB3App: TDB3App;
  30.     DB3Screen: array [0..80,0..80] of char;
  31.     DB3SLastlin: 0..80;
  32.     DB3SCurlin:  0..80;
  33.   StrBuff: array [0..255] of char;
  34.  
  35. {************************}
  36. procedure StrPadR(S: PChar; L: Integer);
  37. {************************}
  38. var
  39. i: integer;
  40.  
  41. begin
  42.     for i:=strlen(S) to L do
  43.       StrCat(S,' ');
  44. end;
  45.  
  46. {************************}
  47. procedure DB3OutLn(S: PChar);
  48. {************************}
  49. begin
  50.     StrCat(DB3Screen[DB3SCurlin],S);
  51.   Inc(DB3SCurlin);
  52.   Inc(DB3SLastlin);
  53. end;
  54.  
  55. {************************}
  56. procedure DB3Out(S: PChar);
  57. {************************}
  58. begin
  59.     StrCat(DB3Screen[DB3SCurlin],S);
  60. end;
  61.  
  62.  
  63. {************************}
  64. PROCEDURE WriteDBError(Errno: Integer);
  65. {************************}
  66. BEGIN
  67.   CASE Errno OF
  68.     NOT_DB_FILE:   DB3OutLn('Not a recognised DBase file');
  69.     INVALID_FIELD: DB3OutLn('Invalid field');
  70.     REC_TOO_HIGH:  DB3OutLn('Tried to read beyond EOF');
  71.     PARTIAL_READ:  DB3OutLn('Only part of record could be read');
  72.     ELSE           DB3OutLn('DBF IO Error');
  73.   END;
  74. END;
  75.  
  76. {************************************}
  77. PROCEDURE WriteDBFormat(D: dbfRecord);
  78. {************************************}
  79. VAR
  80.   CurField: Integer;
  81. BEGIN
  82.   DB3Out('Filename    :    ');
  83.   StrPCopy(StrBuff,D.FileName);
  84.   DB3OutLn(StrBuff);
  85.  
  86.   DB3Out('Last updated    :    ');
  87.   StrPCopy(StrBuff,D.DateOfUpdate);
  88.   DB3OutLn(StrBuff);
  89.  
  90.   DB3Out('Records        :    ');
  91.   Str(D.NumRecs,StrBuff);
  92.   DB3OutLn(StrBuff);
  93.  
  94.   DB3Out('Record length    :    ');
  95.   Str(D.RecLen,StrBuff);
  96.   DB3OutLn(StrBuff);
  97.  
  98.   DB3Out('Number fields    :    ');
  99.   Str(D.NumFields,StrBuff);
  100.   DB3OutLn(StrBuff);
  101.   DB3OutLn(' ');
  102.  
  103.   DB3OutLn('FIELDS:');
  104.   DB3OutLn('NAME        TYPE    LENGTH    DEC    OFF');
  105.   FOR CurField:=1 TO D.NumFields DO
  106.   BEGIN
  107.    StrPCopy(StrBuff,D.Fields^[CurField].Name);
  108.    StrPadR(StrBuff,12);
  109.    StrCat(StrBuff,'    ');
  110.    DB3Out(StrBuff);
  111.  
  112.    StrPCopy(StrBuff,D.Fields^[CurField].Typ);
  113.    StrCat(StrBuff,'    ');
  114.    DB3Out(StrBuff);
  115.  
  116.    Str(D.Fields^[CurField].Len:7,StrBuff);
  117.    DB3Out(StrBuff);
  118.    DB3Out('    ');
  119.  
  120.    Str(D.Fields^[CurField].Dec:4,StrBuff);
  121.    DB3Out(StrBuff);
  122.    DB3Out('    ');
  123.  
  124.    Str(D.Fields^[CurField].Off:4,StrBuff);
  125.    DB3OutLn(StrBuff);
  126.   END;
  127. END;
  128.  
  129. {************************************}
  130. PROCEDURE WriteDBRec(D: dbfRecord; RecNum: Longint;
  131.           VAR dbfError: Integer);
  132. {************************************}
  133. VAR
  134.   CurField: Integer;
  135.   CurByte: Integer;
  136.   FieldOff, FieldEnd: Integer;
  137. BEGIN
  138.   DB3OutLn(' ');
  139.   DB3Out('RECORD: ');
  140.   Str(RecNum,StrBuff);
  141.   DB3OutLn(StrBuff);
  142.   GetDbfRecord(D,Recnum, dbfError);
  143.   IF dbfError<>0 THEN
  144.     WriteDBError(dbfError)
  145.   ELSE
  146.     BEGIN
  147.       CurByte:=1;
  148.       FOR CurField:=1 TO D.NumFields DO
  149.       BEGIN
  150.        FieldOff:=D.Fields^[CurField].Off;
  151.        StrPCopy(StrBuff,D.Fields^[CurField].Name);
  152.        StrPadR(StrBuff,12);
  153.        StrCat(StrBuff,'    :    ');
  154.        DB3Out(StrBuff);
  155.        StrLCopy(StrBuff,@D.CurRecord^[CurByte],D.Fields^[Curfield].Len);
  156.        DB3OutLn(StrBuff);
  157.        CurByte:=CurByte+D.Fields^[Curfield].Len;
  158.       END;
  159.     END;
  160. END;
  161.  
  162.  
  163. {************************************}
  164. procedure DB3DoDem;
  165. {************************************}
  166. BEGIN
  167.   {Set up fields}
  168.   { Use upper case for DBase compatibility }
  169.   testdbfldptr:=@testdbflds;
  170.   testdbflds[1].Name:= 'CUSTOMER';
  171.   testdbflds[1].Typ := 'C';
  172.   testdbflds[1].Len := 20;
  173.   testdbflds[1].Dec := 0;
  174.   testdbflds[1].Off := 1;
  175.  
  176.   testdbflds[2].Name:= 'DATE';
  177.   testdbflds[2].Typ := 'D';
  178.   testdbflds[2].Len := 8;
  179.   testdbflds[2].Dec := 0;
  180.   testdbflds[2].Off := 21;
  181.  
  182.   testdbflds[3].Name:= 'AMOUNT';
  183.   testdbflds[3].Typ := 'N';
  184.   testdbflds[3].Len := 16;
  185.   testdbflds[3].Dec := 0;
  186.   testdbflds[3].Off := 29;
  187.  
  188.   {Create a new database}
  189.   CreateDbf(testdb, 'dbintst.dbf', 3, @testdbflds[1],Iresult);
  190.  
  191.   {Append 3 records}
  192.               {01234567890123456789012345678901234567890123}
  193.   testdbdata:='ALPHA               19910801-100.11         ';
  194.   Move(testdbdata,testdb.CurRecord^,44);
  195.   AppendDbf(testdb,Iresult);
  196.   testdbdata:='BETA                199108022000.22         ';
  197.   Move(testdbdata,testdb.CurRecord^,44);
  198.   AppendDbf(testdb,Iresult);
  199.   testdbdata:='GAMMA               19910803330             ';
  200.   Move(testdbdata,testdb.CurRecord^,44);
  201.   AppendDbf(testdb,Iresult);
  202.   CloseDbf(testdb,Iresult);
  203.  
  204.   {Now open and read the three records that were created}
  205.   testdb.FileName:='dbintst.dbf';
  206.   OpenDbf(testdb,Iresult);
  207.   IF Iresult<>0 THEN WriteDBError(Iresult)
  208.   ELSE
  209.     BEGIN
  210.     WriteDBFormat(testdb);
  211.     WriteDBRec(testdb,1,Iresult);
  212.     WriteDBRec(testdb,2,Iresult);
  213.     WriteDBRec(testdb,3,Iresult);
  214.     END;
  215.  
  216.   CloseDbf(testdb,Iresult);
  217. END;
  218.  
  219. {************************}
  220. procedure TDB3App.InitMainWindow;
  221. {************************}
  222. begin
  223.     MainWindow:=New(PDB3Win,Init(nil,'DBase DLL Demo output'));
  224.   DB3SLastlin:=0;
  225.   DB3SCurlin:=0;
  226.   DB3DoDem;
  227. end;
  228.  
  229. {************************}
  230. procedure TDB3Win.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  231. {************************}
  232. var
  233. i: integer;
  234. TabArr: Integer;
  235. begin
  236.   InvalidateRect(PaintDC,nil,False);
  237.   for i:=0 to DB3SLastLin do
  238.       TabbedTextOut(PaintDC,10,i*20+10,DB3Screen[i],StrLen(DB3Screen[i]),0,TabArr,0);
  239. end;
  240.  
  241. {************************}
  242. { MAIN BODY }
  243. {************************}
  244. BEGIN
  245.     DB3App.Init('DB3DemDl');
  246.   DB3App.Run;
  247.     DB3App.Done;
  248. END.