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

Pascal/Delphi Source File | 1987-12-11 | 13.1 KB | 409 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 high-level calls.                *)
(*                                                                   *)
(*********************************************************************)

(*********************************************************************)
(*              HITADemo - Configuration for compilation             *)
(*                                                                   *)
(*    Follow these steps in order to compile HITADemo.pas:           *)
(*                                                                   *)
(*    1.  Copy TAccess.unit and TAHigh.unit from the Turbo Access    *)
(*        folder into the folder or disk that contains HITADemo.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.  Compile TAHigh.unit to disk.                               *)
(*                                                                   *)
(*    5.  Bring the HITADemo.pas source file into the Turbo Pascal   *)
(*        environment.                                               *)
(*                                                                   *)
(*    6.  Run HITADemo in memory or compile to disk.                 *)
(*                                                                   *)
(*    For further reference, see pages 34-39 of the Turbo Pascal     *)
(*    Database Toolbox Owner's Handbook.                             *)
(*                                                                   *)
(*********************************************************************)

Program HiTADemo;
{$R TAccess.RSRC} { Contains Turbo Access error messages }
{$U TAccess}
{$U TAHigh}              { Use the high-level calls unit }
uses
 {If a compiler error occurs here, Turbo Pascal cannot find the TAccess
  and TAHigh units. You must first compile these units 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, TAHigh;

{$I TADemo.types} { Same type definition file as for TADemo.pas }

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


type
  Filename = string[66];


(**************************************************************)
(*  Global variable are declared here.                        *)
(**************************************************************)
var
  Customers : DataSet;
  CustRecord : 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;
{ Returns true if user types 'Y' to signify yes }
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 the error message to the user and then halts }
begin
  GotoXY(1, 24);
  Write(^G, Message, ', Hit any key to halt.');
  repeat until KeyPressed;
  Halt;
end;

procedure InputInformation(var CustRecord : CustRec);
{ Obtain CustRecord information from the user to put in the data base }
begin
  Writeln;
  Writeln(' Enter customer Information ');
  Writeln;
  with CustRecord 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;
  Writeln;
end; { InputInformation }


(***********************************************************************)
(*  Place the customer information on the screen to be viewed          *)
(***********************************************************************)
procedure DisplayCustomer(CustRecord: CustRec);
begin
  with CustRecord 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;
  Writeln;
end; { Display customer }

procedure ListCustomers(var Customers: DataSet);
{ Lists customer records (ordered by customer codes) on the screen }
var
  Count : LongInt;
  TempCode : CodeStr;
begin
  Count := 0;
  TAReset(Customers);
  repeat
    TANext(Customers, CustRecord, TempCode);
    if Ok then
    begin
      DisplayCustomer(CustRecord);
      Count := succ(Count);
    end;
  until not Ok;
  if Count > 0 then
  begin
    Writeln;
    Writeln(Count, ' total customers');
  end;
end; { ListCustomers }


procedure FindCustomer(var Customers: DataSet;
                       Exact : boolean);
{ Find customer based on customer code.  If Exact is true,
  TARead will be called with an exact match criterion otherwise
  a partial matches will satisfy the search.
}
var
  SearchCode : CodeStr;

begin
  Write('Enter the customer code: ');
  ReadLn(SearchCode);
  TARead(Customers, CustRecord, SearchCode, Exact);
  if OK then
    DisplayCustomer(CustRecord)
  else
    Writeln('A record was not found for the key ',SearchCode);
end { FindCustomer };

procedure NextCustomer(var Customers: DataSet);
{ Next customer based on customer code  }
var
  CustomerCode   : CodeStr;
begin
  TANext(Customers,CustRecord, CustomerCode);
  if OK then
    DisplayCustomer(CustRecord)
  else
    Writeln('The end of the database has been reached.');
end; { Next customer }

procedure PreviousCustomer(var Customers: DataSet);
{ Previous customer based on customer code. }
var
  TempCode : CodeStr;
begin
  TAPrev(Customers, CustRecord, TempCode);
  if OK then
    DisplayCustomer(CustRecord)
  else
    Writeln('The start of the database has been reached.');
end { Previous customer };

procedure AddCustomer(var Customers: DataSet);
{ AddCustomer inserts records into the data file and keys into the index }
var
  TempCode        : CodeStr;
begin
  repeat
    InputInformation(CustRecord);
    TempCode := CustRecord.CustCode;
    TAInsert(Customers, CustRecord, TempCode);
    if Ok then
      Write('Add another record? ')
    else
      Write('Duplicate code exists. Try another code? ');
  until not Confirmed;
end; { AddCustomer }

procedure DeleteCustomer(var Customers: DataSet);
{ DeleteCustomer accepts the customer code and deletes data and key info. }
var
  CustomerCode    : CodeStr;
begin
  repeat
    Write(' Enter code of customer to be deleted: ');
    Readln(CustomerCode);
    TADelete(Customers, CustomerCode);
    if Ok then
      Write('Delete another record? ')
    else
      Write('customer code was not fould. Try another code? ');
  until not Confirmed;
end { DeleteCustomer };

procedure UpdateCustomer(var  Customers : DataSet);
{ UpdateCustomer show a customer and then allow reentry of information }
var
  SearchCode    : CodeStr;

begin
  repeat
    Write('Enter code of customer to be updated: ');
    Readln(SearchCode);
    TARead(Customers, CustRecord, SearchCode, ExactMatch);
    if Ok then
    begin
      DisplayCustomer(CustRecord);
      InputInformation(CustRecord);
      if SearchCode = CustRecord.CustCode then
        TAUpdate(Customers, CustRecord, SearchCode)
      else
      begin
        TAInsert(Customers, CustRecord, CustRecord.CustCode);
        if Ok then
          TADelete(Customers, SearchCode)
        else
          Writeln('Customer Code already used');
      end;
      Write('Update another record? ');
    end
    else
      Write('customer code was not found. Try another code? ');
  until not Confirmed;
end; { Update customer }


(****************************************************************************)
(*  Rebuild's the Data set's index file from the data file                  *)
(****************************************************************************)
procedure RebuildDatabase(var Customers : DataSet);

procedure RebuildIndex(VAR CustFile: DataFile;
                       VAR CodeIndex: IndexFile;
                       FileNm : FileName);
var
  RecordNumber : LongInt;
begin
  MakeIndex(CodeIndex,FileNm,
            SizeOf(CustRecord.CustCode)-1,NoDuplicates);
  if not Ok then
    Abort('Could not Rebuild index file ' + FileNm);
  for RecordNumber := 1 to FileLen(CustFile) - 1 do
  begin
    GetRec(CustFile,RecordNumber, CustRecord);
    If (CustRecord.CustStatus = 0) then
      AddKey(CodeIndex,RecordNumber,CustRecord.CustCode);
  end
end; { RebuildIndex }

begin { RebuildDatabase }
  with Customers do
  begin
    CloseIndex(Index);
    RebuildIndex(Data, Index, IndexFileNm);
  end;
end; { RebuildDatabase }


(*******************************************************************)
(*                          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 file ');
  Writeln(' 0)  Exit ');
  Writeln(' ');
  Action := ReadChar;
  Writeln;
  Menu := UpCase(action);
end { menu };

procedure CleanUp;
begin
  TAClose(Customers);
end;

procedure SetUpDatabase(var Customers : DataSet);
{ Opens up data set (Data and index files) if the files
  exist otherwise the data set is created. }
begin
  TAOpen(Customers, DataFileNm,SizeOf(CustRec),
                    IndexFileNm, SizeOf(CodeStr) - 1);
  if not Ok then
     TACreate(Customers, DataFileNm,SizeOf(CustRec),
              IndexFileNm, SizeOf(CodeStr) - 1);
  if not Ok then
    Abort('Could not create the data set');
    TAErrorProc := @CleanUp;
  { Set up fatal error handler so it will close the database files. }
end; { SetUpDatabase }

(***********************************************************************)
(*                            Main program                             *)
(***********************************************************************)
var
  Finished: Boolean;

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