Eagles Nest BBS 8/Eagles_Nest_Mac_Collection_Disc_8.TOAST/Developer Environments/TurPasDBTlbx/TP-Database Toolbox/Access Samples/TADemo.pas

Pascal/Delphi Source File | 1987-12-11 | 14.3 KB | 438 lines | [TEXT/TPAS]

(*********************************************************************)
(*                  Turbo Pascal Database Toolbox                    *)
(*                       For the Macintosh                           *)
(*            Copyright (C) 1987 Borland International               *)
(*                     Toolbox version: 1.0                          *)
(*                                                                   *)
(*            Turbo Access High-Level Demonstration Program          *)
(*                                                                   *)
(*        Purpose: Shows how to implement a sample database using    *)
(*                 the Turbo Access low-level calls.                 *)
(*                                                                   *)
(*********************************************************************)

(*********************************************************************)
(*              TADemo - Configuration for compilation               *)
(*                                                                   *)
(*    Follow these steps in order to compile TADemo.pas:             *)
(*                                                                   *)
(*    1.  Copy TAccess.unit and TAccess.RSRC from the Turbo Access   *)
(*        folder into the folder or disk that contains TADemo.pas.   *)
(*                                                                   *)
(*    2.  Bring the source for TAccess.unit into the Turbo Pascal    *)
(*        integrated environment.                                    *)
(*                                                                   *)
(*    3.  Modify the $I include file directive to this syntax:       *)
(*        {$I TADemo.const}                                          *)
(*                                                                   *)
(*    4.  Compile TAccess.unit to disk.                              *)
(*                                                                   *)
(*    5.  Bring the TADemo.pas source file into the Turbo Pascal     *)
(*        environment.                                               *)
(*                                                                   *)
(*    6.  Run TADemo in memory or compile to disk.                   *)
(*                                                                   *)
(*    For further reference, see pages 34-39 of the Turbo Pascal     *)
(*    Database Toolbox Owner's Handbook.                             *)
(*                                                                   *)
(*********************************************************************)

Program TADemo;
{$R TAccess.RSRC} { Contains Turbo Access error messages }
{$U TAccess}
uses
 {If a compiler error occurs here, Turbo Pascal cannot find the TAccess
  unit. You must first compile this unit to this disk (or folder if using
  HFS) before compiling HiTADemo. See the top of this file for detailed
  instructions.
 }

  MemTypes, QuickDraw, OSIntF, ToolIntf, PackIntf, TAccess;

{$I TADemo.types}

const
  DataFileNm  = 'Customers.data';
  IndexFileNm = 'Customers.index';

(**************************************************************)
(*  Global variable are declared here.                        *)
(**************************************************************)
var
  CustFile : DataFile;
  CodeIndx : IndexFile;
  Customer : CustRec;

(***********************************************************************)
(*  Utility procedures which can be called from all other procedures   *)
(***********************************************************************)
function UpCase(ch : char): char;
{ Returns the upper case equivalent of ch }
inline
   $301F, { UpCase MOVE.W (SP)+,D0 ; GetCh }
   $0C40,
   $0061, { CMP.W #'a',D0 ; skip if not lower case }
   $6D0A, { BLT.S @1 }
   $0C40,
   $007A, { CMP.W #'z',D0 }
   $6E04, { BGT.S @1 }
   $0440,
   $0020, { SUB.W #$20,D0 }
   $3E80; { @1 MOVE.W D0,(SP) }

function Confirmed : boolean;
var
  Response : char;
begin
  repeat
    Response := UpCase(ReadChar);
    if not (Response in ['Y','N']) then
      SysBeep(1);
  until Response in ['Y','N'];
  Confirmed := Response = 'Y';
  Writeln;
end; { Confirmed }

procedure Pause;
var
  ch : char;
begin
  Writeln;
  Write(' Press any key to continue . . .');
  ch := ReadChar;
end; { Pause }

procedure Abort(Message : string);
{ Reports error to user then halts }
begin
  GotoXY(1, 24);
  Write(^G, Message, ', Hit any key to halt.');
  repeat until KeyPressed;
  Halt;
end;

procedure OpenDataFile(var CustFile : DataFile;
                           Fname: String;
                           Size : integer);
{ Open a Turbo Access data file if it exist, otherwise create it. }
begin
  OpenFile(CustFile, fname, Size);
  if not OK then
    MakeFile(CustFile,fname,Size);
  if not OK then
    Abort('Could not create the data file' + FName);
end;  { OpenDataFile }

procedure InputInformation(var Customer : CustRec);
{ Obtain customer information from the user to put in the data base. }
begin
  Writeln;
  Writeln(' Enter Customer Information ');
  Writeln;
  with Customer do
  begin
    CustStatus := 0;
    Write('Customer code: '); Readln(CustCode);
    Write('Entry date   : '); Readln(EntryDate);
    Write('First name   : '); Readln(FirstName);
    Write('Last name    : '); Readln(LastName);
    Write('Company      : '); Readln(Company);
    Writeln('Address ');
    Write('   Number & Street   : '); Readln(Addr1);
    Write('   City, State & Zip : '); Readln(Addr2);
    Write('Phone     : '); Readln(Phone);
    Write('Extention : '); Readln(PhoneExt);
    Write('Remarks   : '); Readln(Remarks1);
    Write('Remarks   : '); Readln(Remarks2);
    Write('Remarks   : '); Readln(Remarks3);
  end;
end; { InputInformation }

procedure RebuildIndex(VAR CustFile: DataFile;
                       VAR CodeIndex: IndexFile);
{ Rebuild index file based on existing data files. }
var
  RecordNumber : LongInt;
begin
  MakeIndex(CodeIndex, IndexFileNm,
            SizeOf(Customer.CustCode)-1,NoDuplicates);
  for RecordNumber := 1 to FileLen(CustFile) - 1 do
  begin
    GetRec(CustFile,RecordNumber,Customer);
    If Customer.CustStatus = 0 then
      AddKey(CodeIndex,RecordNumber,Customer.CustCode);
  end
end; { RebuildIndex }

procedure OpenIndexFile(var CodeIndx : IndexFile;
                            Fname    : String;
                            KeySize  : integer;
                            Dups     : integer);
{  Setup index file -- open if exists, otherwise create it }
begin
  OpenIndex(CodeIndx, Fname,KeySize,Dups);
  if not Ok then
    MakeIndex(CodeIndx, Fname, KeySize, Dups);
  if not Ok then
    Abort('Could not create the index file ' + Fname);
end; { OpenIndexFile }

procedure DisplayCustomer(Customer: CustRec);
{ Place the customer information on the screen. }
begin
  with Customer do
  begin
    Writeln;
    WriteLn('   Code: ',CustCode,'    Date: ',EntryDate);
    Writeln('   Name: ',FirstName,' ',LastName);
    WriteLn('Company: ',Company);
    Writeln('Address: ',Addr1);
    Writeln('         ',Addr2);
    Writeln('  Phone:',Phone,' ext. ',PhoneExt);
    WriteLn('Remarks: ',Remarks1);
    Writeln('         ',Remarks2);
    WriteLn('         ',Remarks3);
  end;
end; { DisplayCustomer }

procedure FindCustomer(var CustFile: DataFile;
                       var CodeIndx: IndexFile );
{   Find customer based on customer code (exact match)    }
var
  RecordNumber : LongInt;
  SearchCode   : CodeStr;

begin
  Write('Enter the Customer code: '); ReadLn(SearchCode);
  FindKey(CodeIndx,RecordNumber,SearchCode);
  if OK then
  begin
    GetRec(CustFile,RecordNumber,Customer);
    DisplayCustomer(Customer);
  end
  else
    Writeln('A record was not found for the key ',SearchCode);
end { FindCustomer };

procedure SearchCustomer(var CustFile: DataFile;
                         var CodeIndx: IndexFile );
{  Search customer based on customer code (Partial match) }
var
  RecordNumber : LongInt;
  SearchCode   : CodeStr;

begin
  Write('Enter the Partial Customer code: '); ReadLn(SearchCode);
  SearchKey(CodeIndx,RecordNumber,SearchCode);
  if OK then
  begin
    GetRec(CustFile,RecordNumber,Customer);
    DisplayCustomer(Customer);
  end
  else
    Writeln('A record was not found greater than the key ',SearchCode);
end; { SearchCustomer }

procedure NextCustomer(var CustFile: DataFile;
                       var CodeIndx: IndexFile );
{  Next customer based on customer code }
var
  RecordNumber : LongInt;
  SearchCode   : string[15];
begin
  NextKey(CodeIndx,RecordNumber,SearchCode);
  if OK then
  begin
    GetRec(CustFile,RecordNumber,Customer);
    Write('The next customer is : ');
    DisplayCustomer(Customer);
  end
  else
    Writeln('The end of the database has been reached.');
end; { NextCustomer }

procedure PreviousCustomer(var CustFile: DataFile;
                           var CodeIndx: IndexFile);
{ Previous customer based on customer code }
var
  RecordNumber : LongInt;
  SearchCode   : CodeStr;
begin
  PrevKey(CodeIndx,RecordNumber,SearchCode);
  if OK then
  begin
    GetRec(CustFile,RecordNumber,Customer);
    Write('The previous customer is : ');
    DisplayCustomer(Customer);
  end
  else
    Writeln('The start of the database has been reached.');
end; { PreviousCustomer }

procedure ListCustomers(var CustFile: DataFile);
{ Access the customer records sequentially  -- no index files.
  Try rewriting this routine using index files. }
var
  NumberOfRecords,
  RecordNumber    : LongInt;
begin
  NumberOfRecords := FileLen(CustFile);
  Writeln('                   Customers  ');
  Writeln;
  for RecordNumber := 1 to NumberOfRecords - 1 do
  begin
    GetRec(CustFile,RecordNumber,Customer);
    if Customer.CustStatus = 0 then { If valid record }
      DisplayCustomer(Customer);
  end;
end; { ListCustomers }

procedure AddCustomer(var CustFile: DataFile;
                      var CodeIndx: IndexFile);
{ AddCustomer inserts records into the data file and keys into the
  index file. }
var
  RecordNumber    : LongInt;
  TempCode        : CodeStr;
begin
  repeat
    InputInformation(Customer);
    TempCode := Customer.CustCode;
    FindKey(CodeIndx,RecordNumber,TempCode);
    If not OK then
    begin
      AddRec(CustFile,RecordNumber,Customer);
      AddKey(CodeIndx,RecordNumber,Customer.CustCode);
      Write('Add another record? ');
    end
    else
      Write('Duplicate code exists. Try another code? ');
  until not Confirmed;
end; { AddCustomer }

procedure DeleteCustomer(var CustFile: DataFile;
                         var CodeIndx: IndexFile);
{ DeleteCustomer accepts the customer code and deletes data and key info. }
var
  RecordNumber    : LongInt;
  CustomerCode    : CodeStr;
begin
  repeat
    Write(' Enter code of customer to be deleted: '); Readln(CustomerCode);
    FindKey(CodeIndx,RecordNumber,CustomerCode);
    if OK then
    begin
      DeleteKey(CodeIndx,RecordNumber,CustomerCode);
      DeleteRec(CustFile,RecordNumber);
      Write('Delete another record? ');
    end
    else
      Write('Customer code was not fould. Try another code? ');
  until not Confirmed;
end; { DeleteCustomer }

procedure UpdateCustomer(var  CustFile: DataFile;
                         var  CodeIndx: IndexFile);
{ UpdateCustomer shows a customer and then allows reentry of information. }
var
  RecordNumber    : LongInt;
  CustomerCode    : CodeStr;

begin
  repeat
    Write('Enter code of customer to be updated: ');
    Readln(CustomerCode);
    FindKey(CodeIndx, RecordNumber, CustomerCode);
    if OK then
    begin
      GetRec(CustFile,RecordNumber,Customer);
      DisplayCustomer(Customer);
      InputInformation(Customer);
      PutRec(CustFile,RecordNumber,Customer);
      If CustomerCode <> Customer.CustCode Then
      begin
        DeleteKey(CodeIndx,RecordNumber,CustomerCode);
        AddKey(CodeIndx,RecordNumber,Customer.CustCode);
      end;
      Write('Update another record? ');
    end
    else
      Write('Customer code was not found. Try another code? ');
  until not Confirmed;
end; { UpdateCustomer }


(*******************************************************************)
(*                          Main menu                              *)
(*******************************************************************)
function Menu: char;
var
  action: char;
begin
  ClearScreen;
  GotoXY(1,3);
  Writeln('   Enter Number or First Letter');
  Writeln;
  Writeln(' 1)  List Customer Records ');
  Writeln(' 2)  Find a Record by Customer Code ');
  Writeln(' 3)  Search on Partial Customer Code ');
  Writeln(' 4)  Next Customer');
  Writeln(' 5)  Previous Customer');
  Writeln(' 6)  Add to Customer Database ');
  Writeln(' 7)  Update a Customer Record ');
  Writeln(' 8)  Delete a Customer Record ');
  Writeln(' 9)  Rebuild Index files ');
  Writeln(' 0)  Exit ');
  Writeln(' ');
  Action := ReadChar;
  Writeln;
  Menu := UpCase(action);
end { menu };

procedure CleanUp;
{ Called before termination of the program }
begin
  CloseIndex(CodeIndx);
  CloseFile(CustFile);
end; { CleanUp }

procedure SetUpDatabase;
begin
  OpenDataFile(CustFile, DataFileNm,SizeOf(CustRec));
  OpenIndexFile(CodeIndx,IndexFileNm,
                SizeOf(Customer.CustCode)-1,NoDuplicates);
  TAErrorProc := @CleanUp;
  { Set up fatal error handler so it will close the database files. }
end; { SetUpDatabase }

(***********************************************************************)
(*                            Main program                             *)
(***********************************************************************)
var
  Finished: Boolean;
begin
  Finished := false;
  SetUpDatabase;
  repeat
    case Menu of
      '1','L': ListCustomers(CustFile);
      '2','F': FindCustomer(CustFile,CodeIndx);
      '3','S': SearchCustomer(CustFile,CodeIndx);
      '4','N': NextCustomer(CustFile,CodeIndx);
      '5','P': PreviousCustomer(CustFile,CodeIndx);
      '6','A': AddCustomer(CustFile,CodeIndx);
      '7','U': UpdateCustomer(CustFile,CodeIndx);
      '8','D': DeleteCustomer(CustFile,CodeIndx);
      '9','R': begin
                 CloseIndex(CodeIndx);
                 RebuildIndex(CustFile,CodeIndx);
               end;
      '0','E': Finished := true;
      otherwise Write('Choose 0-9: ');
    end; { case }
    if not Finished then
      Pause;
  until Finished;
  CleanUp;
end.