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