home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 8
/
CDASC08.ISO
/
NEWS
/
552
/
XTRASTUF.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-10-07
|
25KB
|
791 lines
UNIT XtraStuf;
{-----------------------------------------------------------------------------
Item Selection Routines
XtraStuf Copyright (c) Richard F. Griffin
14 April 1993
102 Molded Stone Pl
Warner Robins, GA 31088
-------------------------------------------------------------
This unit handles routines to allow display of lists and selection
of items from the list. These routines are provided to show how
GS_dBase units can be used in an application. They are offered
with no guarantee or technical support.
----- NOT FOR USE IN A WINDOWS ENVIRONMENT -----
Changes:
-----------------------------------------------------------------------------}
INTERFACE
USES
Crt,
Dos,
GSOB_Inx,
GSOB_Edt,
GSOB_Str,
GSOB_Dte,
GSOB_Var,
SmplStuf,
GSXT_Bro,
GSOBShel;
var
RecChanged : boolean; {Flag for record changed}
Function FieldAccept(st,Titl : string; x,y : integer) : string;
Procedure FieldDisplay(st,Titl : string; x,y : integer);
Function FieldDisplayScreen : boolean;
Function FieldUpdateScreen : boolean;
Function FieldAppendScreen(empty : boolean) : boolean;
Procedure FieldBrowseScreen;
implementation
var
BrowseOn : boolean;
TopLine : integer;
EndLine : integer;
ActivLin : integer;
ActivFld : integer;
LastLine : integer;
FldLth : integer;
EditOn : boolean;
DeleteOnF9 : boolean; {Flag to permit F9 to delete/undelete}
MyShow : GSO_ShowView;
MyEdit : GSO_EditView;
MemoChg : boolean;
Procedure DrawScreen; Forward;
procedure EditTheMemo;
begin
ClrScr;
MyEdit.Init(DBFActive^.MemoFile^.MemoCollect,
DBFActive^.MemoFile^.Edit_Lgth);
GS_KeyI_Esc := not MyEdit.WorkView;
MemoChg := MyEdit.Modified;
end;
procedure ShowTheMemo;
begin
ClrScr;
MyShow.Init(DBFActive^.MemoFile^.MemoCollect);
GS_KeyI_Esc := not MyShow.WorkView;
MemoChg := false;
end;
Function UpdateOnEsc: boolean;
var
aw : string[2];
begin
{
window(25,10,54,15);
SetScreenColors(Black,Yellow,Green,White,Green);
SetNmMode;
ClrScr;
MakeABox('');
gotoxy(1,1);
}
Window(1,1,80,24);
SetNmMode;
ClrScr;
gotoxy(27,11);
writeln('Record has been modified!');
gotoxy(27,12);
write('Save before exit? ');
AdditionalKeys := Kbd_F1+Kbd_F9+Kbd_F10;
aw := EditString('Y',45,12,1);
UpdateOnEsc := aw[1] in ['T','t','Y','y'];
Window(1,1,80,25);
end;
Function FieldAccept(st,Titl : string; x,y : integer) : string;
var
txtatrb,
i,
v : integer; {Counter variables}
t : string[255]; {Work string to hold default (old) value}
f : string[2];
FNum : integer;
Procedure AcceptC;
var
r_c : string;
begin
SetIVMode;
if EditOn then {If edit permitted, then go edit string}
begin
r_c := t;
AdditionalKeys := Kbd_F1+Kbd_F9+Kbd_F10;
t := EditString(t, v, y, FldLth);
if (GS_KeyI_Chr = Kbd_Esc) and (r_c <> EscStrSave) then
begin
if UpdateOnEsc then t := EscStrSave;
GS_KeyI_Chr := Kbd_Esc;
end;
if t <> r_c then RecChanged := true;
end
else
begin
gotoxy(v,y); {Go to start of field screen position}
write(t,'':FldLth-length(t));
{Rewrite the string on screen inverted}
WaitForKey;
end;
SetNmMode;
gotoxy(v,y); {Go to start of field screen position}
write(t,'':FldLth-length(t));
{Rewrite the string on screen in the original color}
end;
Procedure AcceptD;
var
okDate : boolean;
v1,
v2 : longint;
h1 : string[10];
begin
t := TrimR(t);
v1 := CTOD(t);
t := DTOC(v1);
h1 := t;
FldLth := length(t);
okDate := false;
repeat
EditADate := true;
AcceptC;
EditADate := false;
if EditOn then
begin
if GS_KeyI_Esc then v2 := v1
else v2 := CTOD(t);
if v2 >= 0 then
begin
okDate := true;
t := DTOC(v2);
end
else
begin
if t = h1 then
begin
t := FieldGet(st);
okDate := true;
end;
end;
end else okDate := true;
if not okDate then SoundBell(BeepTime,BeepFreq);
until okDate;
end;
Procedure AcceptL;
var
data : string[1];
begin
{
┌─────────────────────────────────────┐
│ Accept keyboard entry. Loop until │
│ value is T,t,Y,y,F,f,N,n. │
└─────────────────────────────────────┘
}
repeat
if t = '' then t := 'F';
AcceptC;
if not EditOn then exit;
if t[1] in ['T','t','Y','y','F','f','N','n'] then
begin end else SoundBell(BeepTime,BeepFreq);
until t[1] in ['T','t','Y','y','F','f','N','n'];
if t[1] in ['T','t','Y','y'] then t[1] := 'T' else t[1] := 'F';
end;
procedure AcceptM;
var
ans : string[10]; {Work string to hold edit value}
r_c : string[10]; {Work string for memo block number}
lbl : string[10];
begin
if t = '0' then t := '';
SetIvMode;
ans := 'N'; {Initialize ans to false}
GotoXy(v,y);
if EditOn then Write(' Edit ? ') else Write(' View ? ');
repeat
AdditionalKeys := Kbd_F1+Kbd_F9+Kbd_F10;
ans := EditString(ans,v+9,y,1);
{Go edit string t for 1 character}
{at cursor position v,y}
if ans[1] in ['T','t','Y','y','F','f','N','n'] then
begin end else SoundBell(BeepTime,BeepFreq);
until ans[1] in ['T','t','Y','y','F','f','N','n'];
SetNmMode; {Restore original text attribute}
if t = '' then lbl := '---memo---' else lbl := '---MEMO---';
GotoXY(v,y);
Write(lbl);
if ans[1] in ['T','t','Y','y'] then
begin
r_c := t;
MemoGet(st);
If EditOn then EditTheMemo else ShowTheMemo;
if (EditOn) and (GS_KeyI_Esc) and (MemoChg) and
(not UpdateOnEsc) then
begin
ClrScr;
GS_KeyI_Esc := false; {Reset Escape flag so its not used}
{elsewhere}
GS_KeyI_Chr := ' ';
MemoGet(st);
end
else
begin
ClrScr;
GS_KeyI_Chr := ' '; {Clear character last entered}
if EditOn and MemoChg then
begin
MemoPut(st);
t := FieldGet(st);
RecChanged := true;
end;
end;
window(1,1,80,25);
SetScreenColors(Yellow,LightCyan,Blue,Blue,LightGray);
SetNmMode;
ClrScr;
DrawScreen;
if t = '' then lbl := '---memo---' else lbl := '---MEMO---';
GoToXY(v,y);
Write(lbl);
MemoChg := false;
end;
end;
Procedure AcceptN;
var
data : string;
i : integer;
r : real;
begin
{
┌─────────────────────────────────────┐
│ Accept keyboard entry. Loop until │
│ value is Numeric. │
└─────────────────────────────────────┘
}
repeat
if t = '' then Str(0.0:FldLth:FieldDec(FNum),t);
AcceptC;
if not EditOn then exit;
val(t, r, i);
if i = 0 then
begin
Str(r:FldLth:FieldDec(FNum),t);
if length(t) > FldLth then i := 999;
end;
if i <> 0 then
begin
SoundBell(BeepTime,BeepFreq);
t := '';
end;
until i = 0; {i will be 0 when data is a valid number}
gotoxy(v,y); {Go to start of field screen position}
write(t,'':FldLth-length(t));
{Rewrite the string on screen in the original color}
end;
begin
Wait_Cr := false;
GotoXY(x,y); {Go to position on screen}
write(Titl); {Write the title of field}
v := WhereX; {Save the position after writing title}
t := TrimR(FieldGet(st)); {Get the field in the work string}
FNum := FieldNo(st);
FldLth := FieldLen(FNum);
case FieldType(FNum) of
'C' : begin
AcceptC;
FieldAccept := t; {Return the string to calling routine}
end;
'D' : begin
AcceptD;
FieldAccept := t;
end;
'L' : begin
AcceptL;
FieldAccept := t;
end;
'M' : begin
AcceptM;
FieldAccept := t;
end;
'N' : begin
AcceptN;
FieldAccept := t;
end;
end;
Wait_Cr := true;
end;
Procedure FieldDisplay(st,Titl : string; x,y : integer);
var
i,
v : integer; {Counter variables}
t : string[255]; {Work string to hold default (old) value}
data : string[10];
FNum : integer;
begin
GotoXY(x,y); {Go to position on screen}
write(Titl); {Write the title of field}
v := WhereX; {Save the position after writing title}
t := TrimR(FieldGet(st)); {Get the field in the work string}
FNum := FieldNo(st);
FldLth := FieldLen(FNum);
case FieldType(FNum) of
'C',
'L' : begin
gotoxy(v,y); {Go to start of field screen position}
write(t,'':FldLth-length(t));
{Write the string on screen }
end;
'D' : begin
t := DTOC(CTOD(t));;
write(t);
end;
'N' : begin
if t = '' then t := '0';
gotoxy(v,y); {Go to start of field screen position}
write(t:FldLth);
end;
'M' : begin
t := TrimR(t);
if t = '' then t := '---memo---' else t := '---MEMO---';
GotoXY(v,y);
Write(t);
end;
end;
end;
Procedure DrawScreen;
var
i,
x,
y : integer;
st,
s : string[12];
t : string;
begin
SetIvMode;
gotoxy(2,LastLine);
write('':pred(lo(WindMax)-lo(WindMin)));
t := DBFActive^.dfFileName;
if length(t) > 36 then system.delete(t,1,length(t)-36);
gotoxy(40,LastLine);
write(t);
if EditOn then
begin
if RecNo < 0 then {If Append, do the following}
begin
gotoxy(12,LastLine);
write('Append ');
write('EOF/',RecCount);
end
else
begin {If Update do the following}
gotoxy(12,LastLine);
write('Update ');
write(RecNo,'/',RecCount);
end;
end else
begin {If Display then do this}
gotoxy(12,LastLine);
write('Display ');
write(RecNo,'/',RecCount);
end;
if Deleted then
begin
gotoxy(3,LastLine);
write('Deleted');
end;
gotoxy(31,LastLine);
write(#179,'F1-Help',#179);
SetNmMode;
if BrowseOn then exit;
if FieldCount < EndLine then EndLine := FieldCount;
x := 1;
y := 1;
for i := TopLine to pred(TopLine+EndLine) do
begin
s := Field(i);
FillChar(st[1],12,' ');
move(s[1],st[11-length(s)],length(s));
st[11] := ':';
st[0] := #12;
FieldDisplay(s,st,x,y);
case FieldType(i) of
'M' : begin
if RecNo < 0 then FieldPutN(i,' ');
{If Append, make sure memo field is not}
{pointing to a memo block }
end;
end;
ClrEol;
inc(y);
end;
end;
Function FieldDisplayScreen : boolean;
var
f,
h : boolean;
begin
h := EditOn;
EditOn := false;
f := FieldUpdateScreen;
EditOn := h;
FieldDisplayScreen := f;
end;
Function FieldAppendScreen(empty : boolean) : boolean;
begin
if empty then ClearRecord;
DBFActive^.CurRecord^[0] := 32; {Ensure delete flag is off}
DBFActive^.DelFlag := false;
DBFActive^.RecNumber := -1;
FieldAppendScreen := FieldUpdateScreen;
end;
Function FieldUpdateScreen : boolean;
var
i,
x,
y : integer;
st,
s : string[12];
t : string;
udtd : boolean;
Procedure UpdatePage;
var
validcmd : boolean;
begin
validcmd := false;
if ActivFld < TopLine then ActivFld := TopLine;
if ActivFld >= TopLine+EndLine then ActivFld := pred(TopLine+EndLine);
ActivLin := succ(ActivFld - TopLine);
if (ActivLin < 1) or (ActivLin > EndLine) then ActivLin := 1;
repeat
t := FieldAccept(Field(ActivFld),'',13,ActivLin);
if (EditOn) and (not GS_KeyI_Esc) then FieldPutN(ActivFld,t);
if (not GS_KeyI_Fuc) and (GS_KeyI_Chr >= #32) then
GS_KeyI_Chr := Kbd_Ret;
case GS_KeyI_Chr of
Kbd_F1 : begin
ClrScr;
gotoxy(22,10);
writeln('The following commands are available:');
writeln;
writeln('':25,
'Cursor Keys - Up, Down, PgUp, PgDn');
writeln('':25,'Next Line - Return, Tab');
writeln('':25,'Quit - F10');
writeln('':25,'Quit-No Save - Escape');
writeln('':25,'Delete/Undel - F9');
WaitForKey;
ClrScr;
DrawScreen;
end;
Kbd_F9 : begin
if DeleteOnF9 then
begin
if RecNo < 0 then
begin
if Deleted then
DBFActive^.CurRecord^[0] := 32
else DBFActive^.CurRecord^[0] := 42;
DBFActive^.DelFlag := not DBFActive^.DelFlag;
end
else if Deleted then RecallRec else DeleteRec;
end;
gotoxy(3,LastLine);
SetIvMode;
if Deleted then write('Deleted')
else write('':8);
SetNmMode;
end;
Kbd_PgUp : begin
if ActivFld = TopLine then
begin
TopLine := TopLine-EndLine;
if TopLine < 1 then TopLine := 1;
validcmd := true;
end
else ActivFld := TopLine;
end;
Kbd_PgDn : begin
if ActivFld = pred(TopLine+EndLine) then
begin
TopLine := TopLine+EndLine;
if TopLine > FieldCount-EndLine then
TopLine := succ(FieldCount-EndLine);
if TopLine < 1 then TopLine := 1;
validcmd := true;
end
else ActivFld := pred(TopLine+EndLine);
end;
Kbd_UpAr : begin
dec(ActivFld);
if ActivFld < TopLine then
begin
dec(TopLine);
if TopLine < 1 then TopLine := 1;
validcmd := true;
end;
end;
Kbd_RtAr,
Kbd_Tab,
Kbd_Ret,
Kbd_DnAr : begin
inc(ActivFld);
if ActivFld > pred(TopLine+EndLine) then
begin
if ActivFld > FieldCount then
ActivFld := FieldCount
else
begin
inc(TopLine);
if TopLine > FieldCount then
TopLine := succ(FieldCount-EndLine);
validcmd := true;
end;
end;
end;
Kbd_Esc,
Kbd_F10 : validcmd := true;
end;
if ActivFld < TopLine then ActivFld := TopLine;
if ActivFld >= TopLine+EndLine then ActivFld := pred(TopLine+EndLine);
ActivLin := succ(ActivFld - TopLine);
if (ActivLin < 1) or (ActivLin > EndLine) then ActivLin := 1;
until validcmd;
end;
begin
SetNmMode;
ClrScr;
DeleteOnF9 := true;
RecChanged := false;
udtd := false;
TopLine := 1;
ActivFld := TopLine;
LastLine := succ(hi(WindMax)-hi(WindMin));
EndLine := pred(LastLine);
repeat
DrawScreen;
UpdatePage;
until (GS_KeyI_Chr in [Kbd_Esc,Kbd_F10]) or
((GS_KeyI_Chr = Kbd_PgUp) and (ActivFld = 1)) or
((GS_KeyI_Chr = Kbd_PgDn) and (ActivFld = FieldCount));
DeleteOnF9 := false;
if GS_KeyI_Chr in [Kbd_F10, Kbd_PgUp, Kbd_PgDn] then
FieldUpdateScreen := true
else FieldUpdateScreen := false;
end;
Procedure FieldBrowseScreen;
var
lnStart,
lnEnd : word;
broCmd : longint;
broLines : integer;
validcmd : boolean;
CurRow : integer;
LastRec : longint;
Procedure ShoBrowse;
var
i : integer;
j : integer;
t : string;
th : string;
ch : char;
ln : longint;
begin
GoToXY(1,1);
th := GetBrowseHeader(lnStart);
writeln(th);
writeln(GetBrowseBar(lnStart));
j := 2;
for i := 1 to broLines do
begin
t := GetBrowseLine(i, lnStart);
ln := GetBrowseRecord(i);
gotoxy(1,i+2);
if t <> '' then
begin
write(t);
inc(j);
end
else ClrEOL;
end;
if CurRow > j then CurRow := j;
ln := GetBrowseRecord(CurRow-2);
if LastRec <> ln then
begin
SetIvMode;
if Deleted then
begin
gotoxy(3,LastLine);
write('Deleted');
end;
gotoxy(12,LastLine);
write('Browse ');
gotoxy(19,LastLine);
write(ln,'/',RecCount);
LastRec := ln;
end;
SetHiMode;
Gotoxy(1,CurRow);
write(GetBrowseLine(CurRow-2, lnStart));
SetNmMode;
ch := GetKey;
if (not GS_KeyI_Fuc) and (GS_KeyI_Chr >= #32) then
GS_KeyI_Chr := Kbd_Ret;
case GS_KeyI_Chr of
Kbd_F1 : begin
ClrScr;
gotoxy(22,7);
writeln('The following commands are available:');
writeln;
writeln('':25,
'Cursor Keys - PgUp, PgDn, Up, Down,');
writeln('':25,' Right, Left');
writeLn('':25,'Next Field - Tab');
writeLn('':25,'Prev Field - Shift-Tab');
writeLn('':25,'Record Start - Home');
writeLn('':25,'Record End - End');
writeLn('':25,'Top of File - Ctrl-Home');
writeln('':25,'End of File - Ctrl-End');
writeln('':25,'Edit Record - F2');
writeln('':25,'Quit - F10, Escape');
WaitForKey;
ClrScr;
DrawScreen;
LastRec := -1;
end;
Kbd_F2 : begin
EditOn := true;
BrowseOn := false;
ln := GetBrowseRecord(CurRow-2);
Go(ln);
if FieldUpdateScreen then
begin
Replace;
RenewBrowseLine(CurRow-2);
end;
ActivLin := 0;
BrowseOn := true;
EditOn := False;
EndLine := pred(LastLine);
end;
Kbd_Home : begin
lnStart := 1;
end;
Kbd_End : begin
lnStart := 16384;
MoveBrowseRight(lnStart);
end;
Kbd_CHom : begin
UpdateBrowse(broTop);
end;
Kbd_CEnd : begin
UpdateBrowse(broBttm);
end;
Kbd_PgUp : begin
UpdateBrowse(broPgUp);
end;
Kbd_PgDn : begin
UpdateBrowse(broPgDn);
end;
Kbd_UpAr : begin
if CurRow = 3 then
UpdateBrowse(broLnUp)
else
dec(CurRow);
end;
Kbd_DnAr : begin
if CurRow >= EndLine then
UpdateBrowse(broLnDn)
else
inc(CurRow);
end;
Kbd_RtAr : begin
MoveBrowseRight(lnStart);
end;
Kbd_LfAr : begin
MoveBrowseLeft(lnStart);
end;
Kbd_Tab : begin
TabBrowseRight(lnStart);
end;
Kbd_RTb : begin
TabBrowseLeft(lnStart);
end;
Kbd_Esc,
Kbd_F10 : validcmd := false;
end;
end;
begin
EditOn := false;
BrowseOn := true;
SetNmMode;
DeleteOnF9 := true;
RecChanged := false;
TopLine := 1;
ActivLin := 1;
LastLine := succ(hi(WindMax)-hi(WindMin));
EndLine := pred(LastLine);
CurRow := 3;
LastRec := -1;
lnStart := 1;
lnEnd := 79;
validCmd := true;
broCmd := broTop;
broLines := EndLine-2;
ClrScr;
DrawScreen;
StartBrowse(broLines, lnEnd);
UpdateBrowse(broCmd);
repeat
ShoBrowse;
until not validCmd;
ResetBrowse;
DeleteOnF9 := false;
EditOn := true;
BrowseOn := false;
end;
begin
BrowseOn := false;
EditOn := true;
DeleteOnF9 := false; {Turn off F9 for delete/undelete}
end.