home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TBDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  2000-06-30  |  17KB  |  480 lines
  1. (***************************************************************)
  2. (*                                                             *)
  3. (*           TURBO-ACCESS DEMONSTRATION PROGRAM                *)
  4. (*                    Simple Database                          *)
  5. (*                      Version 1.0                            *)
  6. (*                                                             *)
  7. (***************************************************************)
  8.  
  9. Program ExampleDatabaseToolboxConcepts;
  10.  
  11. (***************************************************************)
  12. (*  The following constants are required for data structures   *)
  13. (*  internal to the Database Toolbox.  Please see the example  *)
  14. (*  program, SETCONST.PAS (called SCONST.PAS here in DL1 of    *)
  15. (*  SIG), which helps you select optimal values for these      *)
  16. (*  constants.                                                 *)
  17. (***************************************************************)
  18.  
  19. const
  20.   MaxDataRecSize = 342;
  21.   MaxKeyLen      =  15;
  22.   PageSize       =  16;
  23.   PageStackSize  =  10;
  24.   Order          =   8;
  25.   MaxHeight      =   5;
  26.   NoDuplicates =     0;
  27.  
  28. (*********************************************************************)
  29. (*  The following include directives load in the Toolbox source code *)
  30. (*********************************************************************)
  31.  
  32. {$I ACCESS.BOX }    (* Includes the basic data types and file handling *)
  33. {$I ADDKEY.BOX }    (* Includes the AddKey routine                     *)
  34. {$I DELKEY.BOX }    (* Includes the DelKey routine                     *)
  35. {$I GETKEY.BOX }    (* Includes search routines Find, Search, Prev,    *)
  36.                     (* Next and ClearKey.                              *)
  37.  
  38. (**************************************************************)
  39. (*  The program type definitions can go here.                 *)
  40. (**************************************************************)
  41.  
  42. TYPE
  43.   CustRec = record
  44.     CustStatus : integer;
  45.     CustCode   : string[15];
  46.     EntryDate  : string[8];
  47.     FirstName  : string[15];
  48.     LastName   : string[30];
  49.     Company    : string[40];
  50.     Addr1      : string[40];
  51.     Addr2      : string[40];
  52.     Phone      : string[15];
  53.     PhoneExt   : string[5];
  54.     Remarks1   : string[40];
  55.     Remarks2   : string[40];
  56.     Remarks3   : string[40];
  57.   end; (* CustRec *)
  58.  
  59.   FilenameType = string[64];
  60.  
  61. (**************************************************************)
  62. (*  Global variable are declared here.                        *)
  63. (**************************************************************)
  64.  
  65. var
  66.   CustFile : DataFile;
  67.   CodeIndx : IndexFile;
  68.   Customer : CustRec;
  69.  
  70.  
  71. {  The following code tells you how large to make the MaxDataRecSize
  72.    constant.  If you change the size of you record re-run the code.
  73.  
  74.    Remove the comment bracket below and then run.  Then replace the bracket. }
  75.  
  76.                {
  77.  
  78.     begin
  79.       Writeln('The size of my custrec type is ',SizeOf(CustRec));
  80.       Writeln('The MaxKeyLen is ',sizeof(Customer.CustCode)-1);
  81.     end.
  82.  }
  83.  
  84. (***********************************************************************)
  85. (*  Utility procedures which can be called from all other procedures   *)
  86. (***********************************************************************)
  87.  
  88.   procedure Stop;
  89.   begin
  90.     GotoXY(1,24);
  91.     Writeln;
  92.     Writeln;
  93.     Writeln;
  94.     Writeln('Customer database program aborted.');
  95.     Halt;
  96.   end  { Stop execution };
  97.  
  98. (***********************************************************************)
  99. (*  Open a file if it exist or prompt user if file needs to be created *)
  100. (***********************************************************************)
  101.  
  102.   procedure OpenDataFile(var CustFile : DataFile;
  103.                              Fname: FilenameType;
  104.                              Size : integer     );
  105.   var
  106.     create : char;
  107.   begin
  108.     OpenFile(CustFile, fname, Size);
  109.     if not OK then
  110.     begin
  111.       Writeln(' The data file: ',fname,' was not found.');
  112.       Write('Do you wish to create it? ');
  113.       Read(KBD, Create);
  114.       Writeln(Create);
  115.       if UpCase(create) = 'Y' then
  116.         MakeFile(CustFile,fname,Size)
  117.       else stop;
  118.     end;
  119.     If not OK Then stop;
  120.   end  { OpenDataFile };
  121.  
  122.  
  123. (***********************************************************************)
  124. (*  Obtain customer information from the user to put in the data base  *)
  125. (***********************************************************************)
  126.   procedure InputInformation(var Customer : CustRec);
  127.   begin
  128.     Writeln;
  129.     Writeln(' Enter Customer Information ');
  130.     Writeln;
  131.     with Customer do
  132.     begin
  133.       CustStatus := 0;
  134.       Write('Customer code: '); Readln(CustCode);
  135.       Write('Entry date   : '); Readln(EntryDate);
  136.       Write('First name   : '); Readln(FirstName);
  137.       Write('Last name    : '); Readln(LastName);
  138.       Write('Company      : '); Readln(Company);
  139.       Writeln('Address ');
  140.       Write('   Number & Street   : '); Readln(Addr1);
  141.       Write('   City, State & Zip : '); Readln(Addr2);
  142.       Write('Phone     : '); Readln(Phone);
  143.       Write('Extention : '); Readln(PhoneExt);
  144.       Write('Remarks   : '); Readln(Remarks1);
  145.       Write('Remarks   : '); Readln(Remarks2);
  146.       Write('Remarks   : '); Readln(Remarks3);
  147.     end;
  148.     Writeln;
  149.   end { InputInformation };
  150.  
  151. (***********************************************************************)
  152. (*  Rebuild index files based on existing data files.                  *)
  153. (***********************************************************************)
  154.  
  155.   procedure RebuildIndex(VAR CustFile: DataFile;
  156.                          VAR CodeIndex: IndexFile);
  157.   var
  158.     RecordNumber : integer;
  159.   begin
  160.     InitIndex;
  161.     MakeIndex(CodeIndex,'CodeFile.ndx',
  162.               SizeOf(Customer.CustCode)-1,NoDuplicates);
  163.     for RecordNumber := 1 to FileLen(CustFile) - 1 do
  164.     begin
  165.       GetRec(CustFile,RecordNumber,Customer);
  166.       If Customer.CustStatus = 0 then
  167.         AddKey(CodeIndex,RecordNumber,Customer.CustCode);
  168.     end
  169.   end { Rebuild Index };
  170.  
  171. (***********************************************************************)
  172. (*  Setup index files -- open if exists, create if the user wants to.  *)
  173. (***********************************************************************)
  174.  
  175.   procedure OpenIndexFile(var CodeIndx : IndexFile;
  176.                               Fname    : FilenameType;
  177.                               KeySize  : integer;
  178.                               Dups     : integer);
  179.   var
  180.     create: char;
  181.   begin
  182.     InitIndex;
  183.     OpenIndex(CodeIndx, Fname,KeySize,Dups);
  184.     if not OK then
  185.     begin
  186.       Writeln(' The index file: ',fname,' was not found.');
  187.       Write('Do you wish to create it? ');
  188.       Read(KBD, Create);
  189.       if UpCase(Create) = 'Y' then
  190.         RebuildIndex(CustFile,CodeIndx)
  191.       else
  192.         Stop;
  193.     end;
  194.     If not OK then Stop;
  195.   end  { OpenIndexFile };
  196.  
  197. (***********************************************************************)
  198. (*  Place the customer information on the screen to be viewed          *)
  199. (***********************************************************************)
  200.  
  201.   procedure DisplayCustomer(Customer: CustRec);
  202.   begin
  203.     with Customer do
  204.     begin
  205.       Writeln;
  206.       WriteLn('   Code: ',CustCode,'    Date: ',EntryDate);
  207.       Writeln('   Name: ',FirstName,' ',LastName);
  208.       WriteLn('Company: ',Company);
  209.       Writeln('Address: ',Addr1);
  210.       Writeln('         ',Addr2);
  211.       Writeln('  Phone:',Phone,' ext. ',PhoneExt);
  212.       WriteLn('Remarks: ',Remarks1);
  213.       Writeln('         ',Remarks2);
  214.       WriteLn('         ',Remarks3);
  215.     end;
  216.     Writeln;
  217.   end { Display Customer };
  218.  
  219. (***********************************************************************)
  220. (*  Access the customer records sequentially  -- no index files.       *)
  221. (***********************************************************************)
  222.  
  223.     procedure ListCustomers(var CustFile: DataFile);
  224.     var
  225.       NumberOfRecords,
  226.       RecordNumber    : integer;
  227.       Pause           : char;
  228.     begin
  229.       NumberOfRecords := FileLen(CustFile);
  230.       Writeln('                   Customers  ');
  231.       Writeln;
  232.       for RecordNumber := 1 to NumberOfRecords - 1 do
  233.       begin
  234.         GetRec(CustFile,RecordNumber,Customer);
  235.         if Customer.CustStatus = 0 then DisplayCustomer(Customer);
  236.       end;
  237.       Writeln;
  238.       Write(' Press any key to continue . . .');
  239.       Read(KBD,Pause); Writeln;
  240.     end (* ListCustomers *);
  241.  
  242.  
  243. (************************************************************************)
  244. (*   Find customer based on customer code                               *)
  245. (************************************************************************)
  246.  
  247.   procedure FindCustomer(var CustFile: DataFile;
  248.                          var CodeIndx: IndexFile );
  249.   var
  250.     RecordNumber : integer;
  251.     SearchCode   : string[15];
  252.     Pause        : char;
  253.  
  254.   begin
  255.     Write('Enter the Customer code: '); ReadLn(SearchCode);
  256.     FindKey(CodeIndx,RecordNumber,SearchCode);
  257.     if OK then
  258.     begin
  259.       GetRec(CustFile,RecordNumber,Customer);
  260.       DisplayCustomer(Customer);
  261.     end
  262.     else
  263.       Writeln('A record was not found for the key ',SearchCode);
  264.     Writeln('Press any key to continue . . .');
  265.     Read(KBD,Pause);
  266.   end { FindCustomer };
  267.  
  268. (************************************************************************)
  269. (*   Search customer based on customer code                             *)
  270. (************************************************************************)
  271.  
  272.   procedure SearchCustomer(var CustFile: DataFile;
  273.                            var CodeIndx: IndexFile );
  274.   var
  275.     RecordNumber : integer;
  276.     SearchCode   : string[15];
  277.     Pause        : char;
  278.   begin
  279.     Write('Enter the Partial Customer code: '); ReadLn(SearchCode);
  280.     SearchKey(CodeIndx,RecordNumber,SearchCode);
  281.     if OK then
  282.     begin
  283.       GetRec(CustFile,RecordNumber,Customer);
  284.       DisplayCustomer(Customer);
  285.     end
  286.     else
  287.       Writeln('A record was not found greater than the key ',SearchCode);
  288.     Writeln('Press any key to continue  . . .');
  289.     Read(KBD,Pause);
  290.   end { Search Customer };
  291.  
  292. (************************************************************************)
  293. (*   Next customer based on customer code                               *)
  294. (************************************************************************)
  295.  
  296.   procedure NextCustomer(var CustFile: DataFile;
  297.                          var CodeIndx: IndexFile );
  298.   var
  299.     RecordNumber : integer;
  300.     SearchCode   : string[15];
  301.     Pause        : char;
  302.   begin
  303.     NextKey(CodeIndx,RecordNumber,SearchCode);
  304.     if OK then
  305.     begin
  306.       GetRec(CustFile,RecordNumber,Customer);
  307.       Write('The next customer is : ');
  308.       DisplayCustomer(Customer);
  309.     end
  310.     else
  311.       Writeln('The end of the database has been reached.');
  312.     Writeln('Press any key to continue  . . .');
  313.     Read(KBD,Pause);
  314.   end { Next Customer };
  315.  
  316. (************************************************************************)
  317. (*   Previous customer based on customer code                           *)
  318. (************************************************************************)
  319.  
  320.   procedure PreviousCustomer(var CustFile: DataFile;
  321.                              var CodeIndx: IndexFile);
  322.   var
  323.     RecordNumber : integer;
  324.     SearchCode   : string[15];
  325.     Pause        : char;
  326.   begin
  327.     PrevKey(CodeIndx,RecordNumber,SearchCode);
  328.     if OK then
  329.     begin
  330.       GetRec(CustFile,RecordNumber,Customer);
  331.       Write('The previous customer is : ');
  332.       DisplayCustomer(Customer);
  333.     end
  334.     else
  335.       Writeln('The start of the database has been reached.');
  336.     Writeln('Press any key to continue  . . .');
  337.     Read(KBD,Pause);
  338.   end { Previous Customer };
  339.  
  340. (****************************************************************************)
  341. (*  AddCustomers inserts records into the data file and keys into the index *)
  342. (****************************************************************************)
  343.  
  344.   procedure AddCustomer(var CustFile: DataFile;
  345.                         var CodeIndx: IndexFile);
  346.   var
  347.     RecordNumber    : integer;
  348.     Response        : char;
  349.   begin
  350.     repeat
  351.       InputInformation(Customer);
  352.       FindKey(CodeIndx,RecordNumber,Customer.CustCode);
  353.       If not OK then
  354.       begin
  355.         AddRec(CustFile,RecordNumber,Customer);
  356.         AddKey(CodeIndx,RecordNumber,Customer.CustCode);
  357.         Write('Add another record? ');
  358.       end
  359.       else
  360.         Write('Duplicate code exists. Try another code? ');
  361.       Read(KBD,Response); Writeln(UpCase(Response));
  362.     until UpCase(Response) <> 'Y';
  363.   end { Add a Customer };
  364.  
  365. (****************************************************************************)
  366. (*  DeleteCustomer accepts the customer code and deletes data and key info. *)
  367. (****************************************************************************)
  368.   procedure DeleteCustomer(var CustFile: DataFile;
  369.                            var CodeIndx: IndexFile);
  370.   var
  371.     RecordNumber    : integer;
  372.     Response        : char;
  373.     CustomerCode    : string[15]; { Same as CustRec.CustCode field }
  374.   begin
  375.     repeat
  376.       Write(' Enter code of customer to be deleted: '); Readln(CustomerCode);
  377.       FindKey(CodeIndx,RecordNumber,Customer.CustCode);
  378.       if OK then
  379.       begin
  380.         DeleteKey(CodeIndx,RecordNumber,Customer.CustCode);
  381.         DeleteRec(CustFile,RecordNumber);
  382.         Write('Delete another record? ');
  383.       end
  384.       else
  385.         Write('Customer code was not fould. Try another code? ');
  386.       Read(KBD,Response);
  387.     until UpCase(Response) <> 'Y';
  388.   end { Delete a Customer };
  389.  
  390. (****************************************************************************)
  391. (* UpdateCustomer show a customer and then allow reentry of information     *)
  392. (****************************************************************************)
  393.  
  394.   procedure UpdateCustomer(var  CustFile: DataFile;
  395.                            var  CodeIndx: IndexFile);
  396.     var
  397.       RecordNumber    : integer;
  398.       Response        : char;
  399.       CustomerCode    : string[15]; { Same as CustRec.CustCode field }
  400.     begin
  401.       repeat
  402.         Write('Enter code of customer to be updated: ');
  403.         Readln(CustomerCode);
  404.         FindKey(CodeIndx,RecordNumber,CustomerCode);
  405.         if OK then
  406.         begin
  407.           GetRec(CustFile,RecordNumber,Customer);
  408.           DisplayCustomer(Customer);
  409.           InputInformation(Customer);
  410.           PutRec(CustFile,RecordNumber,Customer);
  411.           If CustomerCode <> Customer.CustCode Then
  412.           begin
  413.             DeleteKey(CodeIndx,RecordNumber,CustomerCode);
  414.             AddKey(CodeIndx,RecordNumber,Customer.CustCode);
  415.           end;
  416.           Write('Update another record? ');
  417.         end
  418.         else
  419.           Write('Customer code was not found. Try another code? ');
  420.         Read(KBD,Response); Writeln(UpCase(Response));
  421.       until UpCase(Response) <> 'Y';
  422.   end { Update customer };
  423.  
  424.  
  425. (*******************************************************************)
  426. (*                          Main menu                              *)
  427. (*******************************************************************)
  428.   function Menu: char;
  429.   var
  430.     action: char;
  431.   begin
  432.     ClrScr;
  433.     GotoXY(1,3);
  434.     Writeln('   Enter Number or First Letter');
  435.     Writeln;
  436.     Writeln(' 1)  List Customer Records ');
  437.     Writeln(' 2)  Find a Record by Customer Code ');
  438.     Writeln(' 3)  Search on Partial Customer Code ');
  439.     Writeln(' 4)  Next Customer');
  440.     Writeln(' 5)  Previous Customer');
  441.     Writeln(' 6)  Add to Customer Database ');
  442.     Writeln(' 7)  Edit a Customer Record ');
  443.     Writeln(' 8)  Delete a Customer Record ');
  444.     Writeln(' 9)  Rebuild Index files ');
  445.     Writeln(' 0)  Exit ');
  446.     Writeln(' ');
  447.     Read(KBD,Action);
  448.     Writeln;
  449.     Menu := UpCase(action);
  450.   end { menu };
  451.  
  452. (***********************************************************************)
  453. (*                            Main program                             *)
  454. (***********************************************************************)
  455. var
  456.   Finished: Boolean;
  457. begin
  458.   Finished := false;
  459.   OpenDataFile(CustFile,'CustFile.dat',SizeOf(CustRec));
  460.   OpenIndexFile(CodeIndx,'CodeFile.Ndx',
  461.                 SizeOf(Customer.CustCode)-1,NoDuplicates);
  462.   repeat
  463.     case Menu of
  464.       '1','L': ListCustomers(CustFile);
  465.       '2','F': FindCustomer(CustFile,CodeIndx);
  466.       '3','S': SearchCustomer(CustFile,CodeIndx);
  467.       '4','N': NextCustomer(CustFile,CodeIndx);
  468.       '5','P': PreviousCustomer(CustFile,CodeIndx);
  469.       '6','A': AddCustomer(CustFile,CodeIndx);
  470.       '7','U': UpdateCustomer(CustFile,CodeIndx);
  471.       '8','D': DeleteCustomer(CustFile,CodeIndx);
  472.       '9','R': RebuildIndex(CustFile,CodeIndx);
  473.       '0','E': Finished := true;
  474.       else     Write('Choose 0-9: ');
  475.     end; { case }
  476.   until Finished;
  477.   CloseIndex(CodeIndx);
  478.   CloseFile(CustFile);
  479. end.
  480.