home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programming
/
powerprogramming1994.iso
/
progtool
/
microcrn
/
issue_44.arc
/
OR4.ARC
/
PULLDOWN.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1988-08-01
|
12KB
|
354 lines
{----------------------------------------------------------------------------}
function Max_Int (Int1,Int2:integer) : integer;
begin
if (Int1 > Int2)
then Max_Int := Int1
else Max_Int := Int2;
end; { End: Max_Int }
{----------------------------------------------------------------------------}
type
sCharDef = set of #0..#255;
{----------------------------------------------------------------------------}
function LeftJust (Subject,Target:string) : string;
var L2 : integer;
begin
L2 := length(Target);
LeftJust := copy(Subject, 1, L2) + copy(Target, length(subject) + 1, L2);
end; { End: LeftJust }
{----------------------------------------------------------------------------}
function RightJust (Subject,Target:string) : string;
var L1,L2 : integer;
begin
L1 := length(Subject); L2 := length(Target);
if (L2 > L1)
then RightJust := copy(Target, 1, L2-L1) + Subject
else RightJust := copy(Subject, 1, L2);
end; { End: RightJust }
{----------------------------------------------------------------------------}
function Center (Subject,Target:string) : string;
var L1,L2,L3 : integer;
begin
L1 := length(Subject); L2 := length(Target);
if (L2 > L1) then begin
L3 := (L2-L1) div 2;
Center := copy(Target, 1, L3) + Subject + copy(Target, L3+L1+1, L2);
end
else Center := copy(Subject, 1, L2);
end; { End: Center }
{----------------------------------------------------------------------------}
function MultiChr (N:integer; InChr:char) : string;
var S1 : string[255];
begin
fillchar(S1, N+1, InChr);
S1[0] := chr(N);
MultiChr := S1;
end; { End: MultiChr }
{----------------------------------------------------------------------------}
function Spaces (N:integer) : string;
begin
Spaces := MultiChr(N, #32);
end; { End: Spaces }
{----------------------------------------------------------------------------}
function DelimParse (var S:string; var BegPtr:integer; sChr:sCharDef; var Delim:char) : string;
{ parses sub-string beginning at BegPtr, ending with string or deliminator. }
{ Init BegPtr = 0, Delim = #0 when returning last substring }
var
NewPtr : integer; Ch : char;
label Loop1;
begin
Delim := #0; NewPtr := BegPtr;
Loop1: if (NewPtr <= Length(S)) then begin
NewPtr := NewPtr + 1; Ch := S[NewPtr];
if not (Ch in sChr) then goto Loop1;
Delim := Ch;
end;
DelimParse := copy(S, BegPtr, NewPtr-BegPtr);
BegPtr := NewPtr+1;
end; { End: DelimParse }
{----------------------------------------------------------------------------}
type
MenuText_ad = array [1..16] of string[32];
{----------------------------------------------------------------------------}
procedure Draw_Window_Box (X0,Y0,Width,Hieght:integer; HdrStr:string);
var
i : integer;
Tmp_Str : string;
begin
Set_Window_Area(X0,Y0+1,Width+2,Hieght); High_Video; clrscr;
Set_Window_Area(X0,Y0,Width+2,Hieght+3);
Med_Video; gotoXY(1,1);
{draw top line of box:}
Tmp_Str := #218 + multichr(Width,#196) + #191;
Tmp_Str := Center(HdrStr,Tmp_Str);
gotoXY(1,1); write(Tmp_Str);
for i := 1 to Hieght do begin
gotoXY(1,i+1); write(#179);
gotoXY(Width+2,i+1); write(#179);
end;
{draw bottom line of box:}
Tmp_Str := #192 + multichr(Width,#196) + #217;
gotoXY(1,Hieght+2); write(Tmp_Str);
end; { End: Draw_Window_Box }
{----------------------------------------------------------------------------}
procedure Draw_PullDown_Window (X0,Y0,SelNo,Width,Hieght:integer; HdrStr:string; aTxStr,aHlStr:MenuText_ad);
var
i,j : integer;
begin
{first draw box around window:}
Draw_Window_Box (X0,Y0,Width,Hieght,HdrStr);
{now fill it in:}
Set_Window_Area(X0,Y0,Width+2,Hieght+3);
for i := 1 to Hieght do begin
gotoXY(2,i+1);
Med_Video;
for j := 1 to length(aTxStr[i]) do begin
if (i = SelNo) then Rev_Video {selection}
else if (aHlStr[i][j] = '^') then High_Video {Highlight}
else Med_Video; {Normal}
if (aHlStr[i][j] = '+')
then write(#254)
else write(aTxStr[i][j]);
end;
end;
end; {Draw_PullDown_Window}
{----------------------------------------------------------------------------}
procedure PullDown_Menu (X,Y:integer; HdrStr,TxStr,HlStr:string; var SelNo,Exit_Sw:integer);
label Out,BreakLoop;
var
Delim1,Delim2,InChar : char;
Last_SelNo,Dummy_Sw : integer;
i,j, Hieght,Width, BP1,BP2 : integer;
aTxStr,aHlStr : MenuText_ad;
begin
Last_SelNo := 0; Exit_Sw := 0;
for i := 1 to 16 do aTxStr[i] := ' ';
{process menu text:}
Width := 0; BP1 := 1; BP2 := 1; Hieght := 0;
repeat {break apart strings}
Hieght := Hieght + 1; { incr array ptr }
aTxStr[Hieght] := DelimParse(TxStr, BP1, ['/','|'], Delim1); {BP1 changed}
aHlStr[Hieght] := DelimParse(HlStr, BP2, ['/','|'], Delim2); {BP2 changed}
Width := Max_Int(Width, length(aTxStr[Hieght]));
until (Delim1=#0);
Draw_PullDown_Window(X,Y,SelNo,Width,Hieght,HdrStr,aTxStr,aHlStr); {draw window}
repeat
Last_SelNo := SelNo;
InChar := GetKey;
case InChar of
{control keys:}
#27: begin Exit_Sw := 2; goto Out; end; {escape}
#222: if (SelNo > 1)
then SelNo := SelNo - 1 {up arrow}
else begin Exit_Sw := 2; goto Out; end; {escape}
#230: if (SelNo < Hieght) then SelNo := SelNo + 1; {dn arrow}
#221: SelNo := 1; {home}
#229: SelNo := Hieght; {end}
#13: begin
if (SelNo = 0)
then Exit_Sw := 2
else Exit_Sw := 1;
goto Out;
end;
'Q': begin Exit_Sw := 2; goto Out; end; {reached only if not defined above}
else begin {other}
for i := 1 to Hieght do begin
j := pos('^',aHlStr[i]); {get position of caret}
if (j > 0) and
(InChar = aTxStr[i][j]) then begin {compare char}
SelNo := i;
Exit_Sw := 1;
goto BreakLoop;
end;
end;
Beep(1500,50); Beep(500,10);
BreakLoop:
end;
end; {end case}
if (SelNo <> Last_SelNo)
then Draw_PullDown_Window(X,Y,SelNo,Width,Hieght,HdrStr,aTxStr,aHlStr); {draw window}
until (g_exit_mode > 0);
Out:
end; {PullDown_Menu}
{----------------------------------------------------------------------------}
procedure Across_Menu(X,Y,SelNo:integer; TxStr,HlStr,SelStr:string);
{writes string at x,y; highlights letters; selection in reverse video}
{Example: TxStr='sel1 sel2'; HlStr='^ ^ '; SelStr='0--- 1---'}
var
TXLen,SelLen,i,SelBeginPos,SelEndPos : integer;
this_char : char;
begin
TXLen := length(TXStr);
SelLen := length(SelStr);
SelBeginPos := Pos(char(SelNo + ord('0')),SelStr);
SelEndPos := SelBeginPos;
while (SelStr[SelEndPos+1] = '-') and (SelEndPos < SelLen)
do SelEndPos := SelEndPos + 1;
Set_Window_Area(X,Y,80,1);
for i := 1 to length(TXStr) do begin
gotoXY(X+i-1,1);
if ((i >= SelBeginPos) and (i <= SelEndPos)) then Rev_Video {selection}
else if (HLStr[i] = '^') then High_Video {Highlight}
else Med_Video; {Normal}
if (HLStr[i] = '+')
then write(#254)
else write(TXStr[i]);
end;
end; {Across_Menu}
{----------------------------------------------------------------------------}
function Rem_Tail_Spaces(InStr:string) : string;
label BreakLoop,Out;
var
i,len : integer;
begin
len := length(InStr);
for i := len downto 1 do begin
if (InStr[i] <> #32) then goto BreakLoop;
end;
Rem_Tail_Spaces := '';
goto Out;
BreakLoop:
Rem_Tail_Spaces := copy(InStr,1,i);
Out:
end; {Rem_Tail_Spaces}
{----------------------------------------------------------------------------}
procedure Pathname_Menu(X,Y:integer; var FileName:string; var Exit_Sw:integer);
label Out;
var
i : integer;
InChar : char;
FileStr : string;
begin
Set_Window_Area(X,Y+1,20+2,5);
Med_Video; gotoXY(1,1);
write(#218); for i := 1 to 20 do write(#196); write(#191);
gotoXY(1,2); write(#179); write('Enter File Pathname:'); write(#179);
gotoXY(1,3); write(#179); write(' '); write(#179);
Med_Video; gotoXY(1,4);
write(#192); for i := 1 to 20 do write(#196); write(#217);
Exit_Sw := 0; FileStr := '';
gotoXY(2,3);
CursorOn;
repeat
InChar := GetKey;
case InChar of
'A'..'Z','-','_','.','0'..'9': begin
if (length(FileStr) < 20) then begin
FileStr := FileStr + InChar;
gotoXY(2,3); write(FileStr);
end;
end;
#225,#8: begin
if (length(FileStr) > 0) then begin
gotoXY(length(FileStr)+1,3); write(#32);
gotoXY(length(FileStr)+1,3);
FileStr := copy(FileStr,1,Length(FileStr)-1);
end;
end;
#13,#222: begin
FileStr := Rem_Tail_Spaces(FileStr);
if (FileStr = '')
then Exit_Sw := 2
else Exit_Sw := 1;
FileName := FileStr;
goto Out;
end;
#27: begin FileName := ''; Exit_Sw := 2; end;
end; {end case}
until (Exit_Sw > 0);
Out:
CursorOff;
end; {Pathname_Menu}
{----------------------------------------------------------------------------}
procedure YesNo_Menu(X,Y:integer; Msg:string; var YesNo_Ch:char; var Exit_Sw:integer);
var
len,i : integer;
Tmp_Ch,InChar : char;
FileStr : string;
begin
len := length(Msg);
Set_Window_Area(X,Y+1,20+2,4);
Med_Video;
gotoXY(1,1); write(#218); for i := 1 to len + 3 do write(#196); write(#191);
gotoXY(1,2); write(#179); for i := 1 to len + 3 do write(#32); write(#179);
gotoXY(1,3); write(#192); for i := 1 to len + 3 do write(#196); write(#217);
Exit_Sw := 0;
gotoXY(2,2); write(Msg);
CursorOn;
InChar := GetKey;
case InChar of
'Y': begin Tmp_Ch := 'Y'; Exit_Sw := 1; YesNo_Ch := 'Y'; end;
'N': begin Tmp_Ch := 'N'; Exit_Sw := 0; YesNo_Ch := 'N'; end;
#27: begin YesNo_Ch := #0; Exit_Sw := 2; YesNo_Ch := #0; end;
end; {end case}
CursorOff;
end; {YesNo_Menu}
{----------------------------------------------------------------------------}
function Ck_In_FileName(FileName:string) : integer;
var
OK : integer;
InFile : file;
begin
assign(InFile, FileName);
{$I-} reset(InFile); {$I+}
OK := IOresult;
if (OK = 0) then close(InFile); {undo any action}
Ck_In_FileName := OK;
case OK of
$00: ;
$01: Msg_Line( 25, 'file does not exist' );
$F2: Msg_Line( 25, 'file dissapeared' );
else Msg_Line( 25, 'filename or disk error' );
end; {end case}
end; {Ck_In_FileName}
{----------------------------------------------------------------------------}
function Ck_Out_FileName(FileName:string) : integer;
var
OK : integer;
OutFile : file;
begin
assign(OutFile, FileName);
{$I-} rewrite(OutFile); {$I+}
OK := IOresult;
if (OK = 0) then close(OutFile); {undo any action}
Ck_Out_FileName := OK;
case OK of
$00: ;
$F0: Msg_Line(25, 'disk write error');
$F1: Msg_Line(25, 'directory is full');
$F2: Msg_Line(25, 'file dissapeared');
else Msg_Line(25, 'filename or disk error');
end; {end case}
end; {Ck_Out_FileName}
{----------------------------------------------------------------------------}