Category : Pascal Source Code
Archive   : TPW73.ZIP
Filename : TPD73.PAS

uses
dos,
crt,
tpw73;

var
mmenu : hmenurec;
smenu : vmenurec;
emenu : vmenurec;
hmenu : vmenurec;
done : boolean;
menunoattr : integer;
x : integer;
msg,msg1 : string;
ch1,ch2 : char;

procedure initmenus;
begin
if lastmode = 7 then
begin
menunoattr := attr(0,0);
winspeed := 3500;
end else menunoattr := attr(8,1);
with mmenu do
begin
curntpos := 0;
item[1] := 'Frames';
item[2] := 'Titles';
item[3] := 'Shadows';
item[4] := 'Demos';
item[5] := 'Menus';
item[6] := 'Quit';
itemcount := 6;
startpos := 1;
hlattr := attr(0,7);
flattr := attr(15,1);
flon := true;
menuspaces := 6;
barloc := 1;
subitem :='001110';
end;
with smenu do
begin
startpos := 0;
liveitem := '11011011';
curntpos := 0;
item[1] := 'Flat ( 0)';
item[2] := 'Reattribute (1, 2)';
item[3] := 'Solid (3, 4)';
item[4] := 'Light Hatch (5, 6)';
item[5] := 'Medium Hatch (7, 8)';
item[6] := 'Heavy Hatch (9,10)';
item[7] := 'Activate Items 3,6 ';
item[8] := 'Deact. Items 3,6 ';
itemcount := 8;
hlattr := attr(0,7);
flattr := attr(15,1);
noattr := menunoattr;
bartype := 1;
flon := true;
end;
with hmenu do
begin
startpos := 0;
liveitem := '1111';
curntpos := 0;
item[1] := 'First Letter';
item[2] := 'Menu Bars ';
item[3] := 'Types ';
item[4] := 'General ';
itemcount := 4;
hlattr := attr(0,7);
flattr := attr(15,1);
noattr := menunoattr;
bartype := 1;
flon := true;
end;
with emenu do
begin
startpos := 0;
liveitem := '111';
curntpos := 0;
item[1] := 'Pop Windows ';
item[2] := 'Zoom Windows';
item[3] := 'List Window ';
itemcount := 3;
hlattr := attr(0,7);
flattr := attr(15,1);
noattr := menunoattr;
bartype := 1;
flon := true;
end;
end;

procedure continue;
begin
sprintc(25,1,80,' Press any key to continue... ',attr(14,7));
repeat
getkey(ch1,ch2);
until ch1 <> #0;
sprintc(25,1,80,'Use arrow keys to change selection - Return to select',attr(0,7));
end;

procedure fdemo;
begin
openwin(5,15,6,15,attr(15,2),attr(15,2),0,0,1,0);
titlewin(2,attr(14,2),'[ Style 0 ]');
openwin(5,34,6,15,attr(15,5),attr(15,5),1,7,1,0);
titlewin(2,attr(14,5),'[ Style 1 ]');
openwin(5,53,6,15,attr(15,3),attr(15,3),2,7,1,0);
titlewin(2,attr(14,3),'[ Style 2 ]');
openwin(8,5,6,15,attr(15,4),attr(15,4),3,7,1,0);
titlewin(2,attr(14,4),'[ Style 3 ]');
openwin(8,24,6,15,attr(15,3),attr(15,3),4,7,1,0);
titlewin(2,attr(14,3),'[ Style 4 ]');
openwin(8,43,6,15,attr(15,6),attr(15,6),5,7,1,0);
titlewin(2,attr(14,6),'[ Style 5 ]');
openwin(8,62,6,15,attr(15,5),attr(15,5),6,7,1,0);
titlewin(2,attr(14,5),'[ Style 6 ]');
openwin(11,15,6,15,attr(15,2),attr(15,2),7,7,1,0);
titlewin(2,attr(14,2),'[ Style 7 ]');
openwin(11,34,6,15,attr(15,7),attr(15,7),8,7,1,0);
titlewin(2,attr(14,7),'[ Style 8 ]');
openwin(11,53,6,15,attr(15,4),attr(15,4),9,7,1,0);
titlewin(2,attr(14,4),'[ Style 9 ]');
openwin(14,5,6,15,attr(15,7),attr(15,7),10,7,1,0);
titlewin(2,attr(14,7),'[ Style 10]');
openwin(14,24,6,15,attr(15,6),attr(15,6),11,7,1,0);
titlewin(2,attr(14,6),'[ Style 11]');
openwin(14,43,6,15,attr(15,5),attr(15,5),12,7,1,0);
titlewin(2,attr(14,5),'[ Style 12]');
openwin(14,62,6,15,attr(15,2),attr(15,2),13,7,1,0);
titlewin(2,attr(14,2),'[ Style 13]');
openwin(17,15,6,15,attr(15,3),attr(15,3),14,7,1,0);
titlewin(2,attr(14,3),'[ Style 14]');
openwin(17,34,6,15,attr(15,2),attr(15,2),15,7,1,0);
titlewin(2,attr(14,2),'[ Style 15]');
openwin(17,53,6,15,attr(15,7),attr(15,7),16,7,1,0);
titlewin(2,attr(14,7),'[ Style 16]');
continue;
for x := 1 to 17 do closewin;
end;

procedure tdemo;
begin
openwin(8,8,10,68,attr(15,5),attr(15,5),2,0,1,0);
printcwin(3,'Titles may be placed in any of six different locations');
printcwin(4,'and in any color attribute!');
for x:=1 to 6 do
begin
str(x,msg);
msg := '[ LOCATION '+MSG+' ]';
titlewin(x,attr(9+x,5),msg);
delay(1000);
end;
continue;
closewin;
end;

procedure sdemo;
begin
openwin(3,30,10,25,attr(7,1),attr(15,1),10,7,1,0);
done := false;
with smenu do
begin
while not done do
begin
makevmenu(smenu);
case curntpos of
1 : begin
openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
titlewin(2,attr(15,5),' FLAT ');
openwin(11,8,10,30,attr(15,3),attr(0,3),1,0,0,0);
openwin(11,43,10,30,attr(15,7),attr(1,7),1,0,0,0);
continue;
closewin;
closewin;
closewin;
end;
2 : begin
openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
titlewin(2,attr(15,5),' REATTRIBUTE ');
openwin(11,8,10,30,attr(15,3),attr(0,3),2,7,1,0);
printcwin(7,'Left Shadow');
openwin(11,43,10,30,attr(15,7),attr(1,7),2,7,2,0);
printcwin(7,'Right Shadow');
continue;
closewin;
closewin;
closewin;
end;
3 : begin
openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
titlewin(2,attr(15,5),' SOLID ');
openwin(11,8,10,30,attr(15,3),attr(0,3),2,0,3,0);
printcwin(7,'Left Shadow');
openwin(11,43,10,30,attr(15,7),attr(1,7),2,0,4,0);
printcwin(7,'Right Shadow');
continue;
closewin;
closewin;
closewin;
end;
4 : begin
openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
titlewin(2,attr(15,5),' LT. HATCH ');
openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),5,0);
printcwin(7,'Left Shadow');
openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),6,0);
printcwin(7,'Right Shadow');
continue;
closewin;
closewin;
closewin;
end;
5 : begin
openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
titlewin(2,attr(15,5),' MED. HATCH ');
openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),7,0);
printcwin(7,'Left Shadow');
openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),8,0);
printcwin(7,'Right Shadow');
continue;
closewin;
closewin;
closewin;
end;
6 : begin
openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
titlewin(2,attr(15,5),' HEAVY HATCH ');
openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),9,0);
printcwin(7,'Left Shadow');
openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),10,0);
printcwin(7,'Right Shadow');
continue;
closewin;
closewin;
closewin;
end;
7 : begin
liveitem[3] := '1';
liveitem[6] := '1';
end;
8 : begin
liveitem[3] := '0';
liveitem[6] := '0';
end;
else
closewin;
done := true;
end;
end;
done := false;
end;
end;

procedure showfile;
var
source : text;
txtstr : string;
txtarray : lstarray;
rec : word;

begin
rec := 0;
Assign(Source,'LMENUTP.TXT');
{$I-} Reset(Source); {$I+}
if ioresult = 0 then
begin
mark(heaptop);
repeat
{$I-} readln(source,txtstr); {$I+}
if ioresult = 0 then
begin
inc(rec);
new(TxtArray[rec]);
TxtArray[rec]^ := txtstr;
end;
until eof(source);
close(source);
openwin(7,7,12,16,attr(1,7),attr(1,7),2,0,1,0);
titlewin(2,attr(1,7),' KEYWORDS ');
titlewin(5,attr(1,7),' more ');
x := MakeLMenu(txtarray,rec,1,attr(7,1));
closewin;
if x <> 0 then
begin
openwin(12,24,7,34,attr(1,7),attr(1,7),2,0,1,1);
printcwin(2,'Record selected:');
printcwin(4,txtarray[x]^);
continue;
closewin;
end;
release(heaptop);
end;
end;

procedure edemo;
begin
openwin(3,43,5,18,attr(7,1),attr(15,1),10,attr(7,0),1,0);
done := false;
with emenu do
begin
while not done do
begin
makevmenu(emenu);
case curntpos of
1 : begin
openwin(8,8,10,65,attr(15,5),attr(15,5),2,0,1,0);
printcwin(3,'Windows can be popped');
printcwin(4,'onto the screen.');
delay(2000);
openwin(5,5,10,50,attr(0,2),attr(14,2),2,7,1,0);
delay(2000);
openwin(13,15,10,60,attr(1,3),attr(15,3),3,7,1,0);
delay(2000);
openwin(7,33,10,45,attr(14,5),attr(14,5),1,7,1,0);
continue;
for x := 1 to 4 do
begin
closewin;
end;
end;
2 : begin
openwin(8,8,10,65,attr(15,5),attr(15,5),2,0,1,0);
printcwin(3,'Windows can be zoomed');
printcwin(4,'onto the screen.');
delay(2000);
openwin(5,5,10,50,attr(0,2),attr(14,2),2,7,1,1);
delay(2000);
openwin(13,15,10,60,attr(1,3),attr(15,3),3,7,1,1);
delay(2000);
openwin(7,33,10,45,attr(14,5),attr(14,5),1,7,1,1);
delay(2000);
openwin(7,20,12,40,attr(15,4),attr(14,4),2,7,1,1);
printcwin(5,'HOW ABOUT THAT !!!');
continue;
for x := 1 to 5 do
begin
closewin;
end;
end;
3: showfile;
else
closewin;
done := true;
end;
end;
done := false;
end;
end;

procedure flhelp;
begin
openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
titlewin(2,attr(15,7),'[ FIRST LETTER ]');
printwin(1,2,'To activate First Letter control you must set two');
printwin(2,2,'variables. FLOn must be set to true and you can');
printwin(3,2,'set FLattr to the desired color you wish. Thats');
printwin(4,2,'all there is to it. Just be sure all strings begin');
printwin(5,2,'with a different letter.');
continue;
closewin;
end;

procedure barhelp;
begin
openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
titlewin(2,attr(15,7),'[ MENUBARS ]');
printwin(1,2,'There are currently four menu bar types:');
printwin(2,2,' 0 - No visible bar 1 - Full width bar');
printwin(3,2,' 2 - String width bar 3 - Pointer');
printwin(4,2,'You control what type is active by setting BarType');
printwin(5,2,'equal to the type desired.');
continue;
closewin;
end;

procedure typehelp;
begin
openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
titlewin(2,attr(15,7),'[ MENUTYPES ]');
printwin(1,2,'There are currently two menu types:');
printwin(2,2,' Standard Vertical Menu (Makevmenu)');
printwin(3,2,' Horizontal Menu (Makehmenu)');
printwin(4,2,' List Menu (Makelmenu)');
continue;
closewin;
end;

procedure generalhelp;
begin
openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
titlewin(2,attr(15,7),'[ GENERAL ]');
printwin(1,2,'Remember MakeMenu is only a procedure executed in a');
printwin(2,2,'predefined window so all window effects can be used');
printwin(3,2,'to enhance your menu. Including border and shadow,');
printwin(4,2,'as well as growing and all various color attribute');
printwin(5,2,'combinations. The choices are almost endless!');
continue;
closewin;
end;

procedure hdemo;
begin
openwin(3,54,6,18,attr(7,1),attr(15,1),10,attr(7,0),1,0);
done := false;
with hmenu do
begin
while not done do
begin
makevmenu(hmenu);
case curntpos of
1 : flhelp;
2 : barhelp;
3 : typehelp;
4 : generalhelp;
else
closewin;
done := true;
end;
end;
done := false;
end;
end;

begin
clrscr;
cursoroff;
openwin(5,20,11,40,attr(15,7),textattr,2,0,0,0);
printcwin(2,'TPW73');
case CurDisplay of
0 : msg := 'MONO';
1 : msg := 'CGA';
2 : msg := 'EGA';
3 : msg := 'MCGA';
4 : msg := 'VGA';
end;
str(lastmode:1,msg1);
msg := msg + ' monitor in video mode '+msg1;
printcwin(3,msg);
printcwin(5,'Copyright (C) 1988');
printcwin(6,'by Richard D. Fothergill');
initmenus;
x := 0;
while not keypressed and (x < 25000) do inc(x);
closewin;
if keypressed then getkey(ch1,ch2);
done := false;
openwin(1,1,3,80,attr(7,1),attr(15,1),2,0,0,0);
fakewin(3,1,22,80,attr(7,1),attr(15,1),14,0,0,0);
sprint(25,1,' Use arrow keys to change selection - Return to select ',attr(0,7));
with mmenu do
begin
while not done do
begin
makehmenu(mmenu);
case curntpos of
1 : fdemo;
2 : tdemo;
3 : sdemo;
4 : edemo;
5 : hdemo;
else
closewin;
clrscr;
openwin(9,16,8,52,attr(0,7),attr(1,7),2,0,0,0);
printcwin(3,'T P W');
printcwin(4,'7.3');
delay(3000);
closewin;
done := true;
end;
end;
end;
cursoron;
clrscr;
end.