[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

    unit DBaseDB;
    {$V-,S-,R-}
    {              ***************24/10/97*****************
                   *This UNIT was created by DAVID HOOPER*
                   *for general use, can use filelocking *
                   *A record level locking version will  *
                   *be available soon. Both going to SWAG*
                   *          loki1@ihug.co.nz           *
                   *  http://homepages.ihug.co.nz/~loki1 *
                   ***************************************}

    interface
    uses Dos; {, MyDBase;}
    type
        string30 = string[30];
    {****NB:****  To use custom records:
         The Simple Way:- Do a SEARCh and REPLACE for DBase and replace it
           with your database name, (max 6 letters) eg. PLAYER or USERS
           also edit the DBaseRec (PLAYERRec) and put your own fields in.

         The other way :-
                  make a simple unit that has just the record structure
                  DBaseRec, and also the Vars
                  DBase: DBaseRec;
                  DBaseFile: File of DBaseRec;
                  and include the USES Dos, MyDBase line (where MyDBase
                  is the unit with your structures in it)
                  then delete them from this unit

        An Example of using this DBase is at the end of this file}
        MemoType = Record
                     Memo_Date: string[15];
                     Memo_Line: string;
                   End;
        DBaseRec = Record             {this is an example, make your own}
                     Deleted: boolean;{delete DBaseFINDDELD if u delete this}
                     Name: string30;  {delete DBaseFINDNAME if u delete this}
                     Age: byte;
                     Memo: array[1..10] of MemoType;
                    End;
    Var
      {GLOBAR VARIABLES}
       DBase : DBaseRec;
       DBaseFile : File of DBaseRec;
       OldFileMode : integer;
       RecFoundAT: word; {where was the searched for record found}

    function FILEEXISTS(PathAndFile: string):Boolean;
    function  DBaseOPEN(Path, FileName: string; fm: byte): Boolean;
    procedure DBaseCLOSE;
    procedure DBaseREAD(var DBase: DBaseRec);  {not normally used by user}
    function  DBaseSEEK(Rec: word) : boolean;  {not normally used by user}
    function  DBaseGET(var DBase: DBaseRec; Rec: word) :Boolean;{uses above 2}
    procedure DBaseADD(var DBase: DBaseRec);
    procedure DBaseEDIT(var DBase: DBaseRec);
    function  DBaseCREATEFIRST(Path, FileName: string; fm: byte;
                                   var DBase: DBaseRec): Boolean;
    function  DBaseFINDNAME(var DBase: DBaseRec; InName: string30): Boolean;
    function  DBaseFINDDEL(var DBase: DBaseRec): Boolean;
    procedure DBaseSORT;

    implementation

    {***********************************
     *Opens the DBase file and returns *
     *TRUE if successful               *
     *fm= filemode:- 0=read, 2= write  *
     *64=read&share, 66=write&share    *
     ***********************************}
    function FILEEXISTS(PathAndFile: string):Boolean;
    var F: File;
    begin
      assign(F,PathAndFile);
    {$I-}
      reset(f);
    {$I+}
      if ioresult = 0 then
      begin
        close(f);
        fileExists := true;
      end
      else
      fileExists := false;
    end;

    function DBaseOPEN(Path, FileName: string; fm: byte): Boolean;
    var S: string;
     IsOK: Boolean;
    begin
     S := FSearch(FileName,Path); {check it exists}
     IsOK := True;
     if ((fm = 0) or (fm = 64)) then IsOk := FILEEXISTS(Path+FileName);
     if IsOK then
     begin
      {$I-}
      OldFileMode := filemode;
      filemode := fm;
      Assign(DBaseFILE , Path+FileName);
      Reset(DBaseFILE);
      IsOK := (ioresult = 0);
      {$I+}
     end;
     if (not IsOK) then filemode := OldFileMode;
     DBaseOPEN := IsOK;
    end;

    {************************
     *Closes the DBase file *
     ************************}
    procedure DBaseCLOSE;
    begin
     CLOSE(DBaseFILE);
     filemode := OldFileMode;
    end;

    {***********************************
     *Seeks to a specific record number*
     *0 to end of file. Will return a  *
     *True if REC is within the range  *
     *Normally not used by user, but   *
     *here if needed                   *
     ***********************************}
    function DBaseSEEK(Rec: word) : boolean;
    begin
     if (((Rec+1) <= (FileSize(DBaseFILE))) and (Rec >=0)) then
     begin
      Seek(DBaseFILE, Rec);
      DBaseSEEK := True;
     end
     else DBaseSEEK := False;
    end;

    {**************************************
     *Simply Reads the next record.       *
     *Again, normally only used internally*
     *by other functions and procedures   *
     *such as DBaseGET, after range check *
     **************************************}
    procedure DBaseREAD(var DBase: DBaseRec);
    begin
     Read(DBaseFILE , DBase);
    end;

    {**************************************
     *Seeks to Rec with range checking    *
     *Reads in the record and returns and *
     *returns TRUE if successful or FALSE *
     *if Rec was out of range             *
     **************************************}
    function DBaseGET(var DBase: DBaseRec;Rec: word) : boolean;
    var IsOK: boolean;
    begin
     IsOK := DBaseSEEK(Rec);
     if IsOK then DBaseREAD(DBase);
     DBaseGET := IsOK;
    end;

    {************************************************
     *Writes the DBase record to the current        *
     *Record number. This is usually called         *
     *like thius:-                                  *
     *If DBaseSeek(Rec_Number) then EDITDBase(DBase)*
     ************************************************}
    procedure DBaseEDIT(var DBase: DBaseRec);
    begin
     write(DBaseFILE, DBase);
    end;

    {************************************************
     *Writes a new record to the end of the database*
     ************************************************}
    procedure DBaseADD(var DBase: DBaseRec);
    begin
     RESET(DBaseFile);  {this line can be removed}
     SEEK(DBaseFILE, filesize(DBaseFile));
     DBaseEDIT(DBase);
    end;

    {*********************************************************
     *An alternate to automatically making a new file        *
     *If it does not exist.(eg. may just be a wrong          *
     *path. An example of calling this is :-                 *
     *if (NOT OPENDBase('C:\DATA\','MyDBase.DAT',2))         *
     *  then CREATEFIRSTDBase('C:\DATA\'MyDBase.Dat', DBase);*
     *the filemode that is passed, is used to reopen the file*
     *after it has been created. First record written assumes*
     *SharingWrite 66                                        *
     *********************************************************}
    function DBaseCREATEFIRST(Path, FileName: string; fm: byte;
                                   var DBase: DBaseRec):boolean;
    begin
      {$I-}
      OldFileMode := filemode;
      filemode := 66;
      Assign(DBaseFILE , Path+FileName);
      Rewrite(DBaseFILE);
      {$I+}
     if ioresult <>0 then
     begin
       DBaseCREATEFIRST := False;
       exit;
     end;
     DBaseEDIT(DBase);
     close(DBaseFile);
     DBaseCREATEFIRST := DBaseOPEN(Path, FileName, fm);
    end;

    {*********************************************
     *Finds a name, and returns the record number*
     *in RecFoundAt, and a TRUE, else            *
     *RecFoundAt = 0, and function returns FALSE *
     *********************************************}
    function  DBaseFINDNAME(var DBase: DBaseRec; InName: string30): Boolean;
    var L1, UCLoop: word;
        found: boolean;
        TBName, TIName: string30;
    begin
     L1 := 0;
     found := False;
     for UCLoop := 1 to length(InName) do InName[UCLoop] := upcase(InName[UCLoop]);
     while ((L1 < filesize(DBaseFile)) and (not found)) do
     begin
      if (DBaseGET(DBase, L1)) then
        TBName := DBase.Name;
        for UCLoop := 1 to length(TBName) do TBName[UCLoop] := upcase(TBName[UCLoop]);
         if ((TBName = InName) and (not DBase.deleted)) then found := true
         else found := false;
      if not found then inc(L1);
     end;

     if Found then
     begin
       RecFoundAt := L1;
       DBaseSEEK(L1);
       DBaseFINDNAME := TRUE;
     end
     else
     begin
       RecFoundAt := 0;
       DBaseFINDNAME := FALSE;
     end;
    end;

    {*********************************************
     *Finds the first Deleted (empty) record.    *
     *ie. DBase.Deleted := TRUE. returns record #*
     *in RecFoundAt, and a TRUE, else            *
     *RecFoundAt = 0, and function returns FALSE *
     *********************************************}
    function  DBaseFINDDEL(var DBase: DBaseRec): Boolean;
    var L1: word;
     found: boolean;
    begin
     L1 := 0;
     found := False;
     while ((L1 < filesize(DBaseFile)) and (not found)) do
     begin
      if (DBaseGET(DBase, L1)) then found := (DBase.Deleted = True);
      if not found then inc(L1);
     end;
     if Found then
     begin
       RecFoundAt := L1;
       DBaseSEEK(L1);
       DBaseFINDDEL := TRUE;
     end
     else
     begin
       RecFoundAt := 0;
       DBaseFINDDEL := FALSE;
     end;
    end;

    PROCEDURE DBaseSORT;
    var SORTLOOP: word;
        TempDBase: DBaseRec;
        DidSort: boolean;     {flag eg. why continue sorting when sorted?}
        count, endcount: integer;
    begin
      count := 0;
      endcount := FileSize(DBaseFILE)-3;
      {-2(-3) because we do +1 in the search}
      DidSort := TRUE; {set true for first sort}
      while (DidSort AND (count <= endcount)) do
      begin
        DidSort := FALSE;
        for SortLoop := 0 to (FileSize(DBaseFILE)-(1+Count)) do
        begin
          DBaseGET(DBase, SortLoop);
          TempDBase := DBase;
          DBaseGET(DBase, SortLoop+1);
          if ((TempDBase.Name > DBase.Name) or (TempDBase.Deleted)) then
          {swap order, put deleted at end}
          begin
            DidSort := TRUE;                {Swapping part, uses a temp record}
            DBaseSEEK(SortLoop);
            write(DBaseFILE, DBase);
            DBaseSEEK(SortLoop+1);
            write(DBaseFILE, TempDBase);
          end;
        end; {of SortLoop}
        Count := Count + 1;
      end; {of while loop}
    end;

    begin
    end.

    (*  EXAMPLE OF USING THE DBASEDB UNIT
    program TESTDB(input, output);
    uses DBASEDB;
    var
       Loop1: word; {only used for example}

    begin
      if not FILEEXISTS('C:\TESTDB.DAT') then {no database made yet}
      begin
        DBase.Deleted := False;
        DBase.Name := 'First Person';
        DBase.Age := 27;
        DBase.Memo[1].Memo_Date := '27/10/97';
        DBase.Memo[1].Memo_Line := 'Meeting went well...';

        DBaseCREATEFIRST('C:\','TESTDB.DAT',66, DBase); {make the new database}
      end
      else {the database file DOES exist}
        DBaseOpen('C:\','TESTDB.DAT',66);{so open it}

        DBase.Deleted := False;
        DBase.Name := 'Joe Bloggs';
        DBase.Age := 23;
        DBase.Memo[1].Memo_Date := '23/10/97';
        DBase.Memo[1].Memo_Line := 'didn''t show for Meeting';
        DBaseADD(DBase); {ADD THIS RECORD}

        DBase.Deleted := False;
        DBase.Name := 'Fred Flintstone';
        DBase.Age := 47;
        DBase.Memo[1].Memo_Date := '29/11/97';
        DBase.Memo[1].Memo_Line := 'bought a new car';
        DBase.Memo[2].Memo_Date := '30/11/97';
        DBase.Memo[2].Memo_Line := 'crashed the new car';
        DBaseADD(DBase); {ADD THIS RECORD}

        writeln('There are ',filesize(DBaseFile),' records');
        for Loop1 := 0 to filesize(DBaseFile)-1 do  {-1 because first record}
        begin                                       {is record 0 (zero)     }
          DBaseGet(DBase, Loop1);
          with DBase do
          begin
            Writeln('Record: ',Loop1);
            Writeln(Name,'   ',Age);
          end;
        end;
       if DBaseFINDNAME(DBase, 'Fred Flintstone') then
       begin
         writeln('First name matching ''Fred Flintstone'' found at ',RecFoundAt);
         DBaseGet(DBase, RecFoundAt);        {or simply DBaseREAD(DBASE); since}
         Writeln(DBase.Name,'   ',DBase.Age);{FINDNAME Seeks to the start of it}
       end
       else writeln ('''Fred Flintstone'' not found');
       DBaseClose;
    end.
    *)

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]