[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]