Category : Pascal Source Code
Archive   : TOPS.ZIP
Filename : MENU123.PAS

UNIT MENU123;

INTERFACE
USES IOSTUFF,CRT,DOS;
PROCEDURE Reset123;
PROCEDURE SetMenu123(X,Y:Integer;MenuStr:AnyStr);
FUNCTION PickMenu123 : Char;

IMPLEMENTATION

CONST
ColorF1 = Yellow; { Menu Colors }
ColorB1 = Blue;
ColorF2 = LightCyan; { Foreground Color - First Letter }
ColorB2 = Blue;
ColorF3 = Black; { Reverse Video bar cursor }
ColorB3 = LightGray;
MaxMenuItems = 12;
Sp = 3; { Number of additional pad spaces between }
{ menu picks. Sp = 3 gives 4 spaces total }
VAR
XPos,YPos : Integer;
MenuMsg : Array[1..MaxMenuItems] of ShortStr; { Make this longer if needed }
MenuLtr : Array[1..MaxMenuItems] of Char;
MenuOfs : Array[1..MaxMenuItems] of Integer;
NumPicks : Integer;
Pick : Integer;
LastPick : Integer;
SaveAttr : Byte;
{============================================================================}

PROCEDURE Reset123;
VAR
P : Integer;
BEGIN
SaveAttr := TextAttr;
SetColor(ColorF1,ColorB1);
GoToXY(1,YPos);ClrEol;
For P := 1 to NumPicks do begin
SetColor(ColorF1,ColorB1);
WriteSt(MenuMsg[P],XPos+MenuOfs[P],YPos);
SetColor(ColorF2,ColorB2);
WriteCh(MenuLtr[P],XPos+MenuOfs[P],YPos);
End;
TextAttr := SaveAttr;
END;
{============================================================================}

PROCEDURE SetMenu123(X,Y:Integer;MenuStr:AnyStr);

VAR
CPos : Integer;
Len : Integer;

BEGIN
XPos := X; YPos := Y;
Pick := 1;
LastPick := 1;
CPos := 1;
NumPicks := 0;
Repeat

If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
Len := Pos('/',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
MenuOfs[NumPicks] := CPos+Sp*(NumPicks-1);
CPos := CPos+Len+1;

Until CPos >= Length(MenuStr);
Reset123;

END;

{============================================================================}
FUNCTION PickMenu123 : Char;

CONST
LeftArrow = #75;
RightArrow = #77;
DownArrow = #80;
EnterKey = #13;
EscKey = #27;
Abort = #0;
VAR
Err,II : Integer;
Ch : Char;
PickExit : Boolean;
BeepOn : Boolean;
FunctKey : Boolean;

BEGIN
SaveAttr := TextAttr;
PickExit := False;
SetColor(ColorF3,ColorB3);
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
HideCursor;
Repeat

Ch := Readkey;
If Ch <> #0 then FunctKey := False else
Begin
Ch := ReadKey;
FunctKey := True;
End;


If not FunctKey then Case Ch of
#32..#125: Begin
BeepOn := True;
For II := 1 to NumPicks do Begin
If UpCase(Ch) = UpCase(MenuLtr[II]) then Begin
Pick := II;
PickExit := True;
BeepOn := False;
End;
End;
If BeepOn then Beep;
End;
EnterKey,
EscKey : PickExit := True;

End; {case not functkey}

If FunctKey then Case Ch of
LeftArrow : Pick := Pick - 1;
RightArrow : Pick := Pick + 1;
DownArrow : PickExit := True;
Else Beep;

End; {case functkey}


If Pick > NumPicks then Pick := 1;
If Pick < 1 then Pick := NumPicks;

If Pick <> LastPick then Begin
SetColor(ColorF1,ColorB1);
WriteSt(' '+MenuMsg[LastPick]+' ',XPos-1+MenuOfs[LastPick],YPos);
SetColor(ColorF2,ColorB2);
WriteCh(MenuLtr[LastPick],XPos+MenuOfs[LastPick],YPos);

SetColor(ColorF3,ColorB3);
WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);

LastPick := Pick;
End;

Until PickExit;

If Ch = EscKey then PickMenu123 := Abort
else PickMenu123 := MenuLtr[Pick];
ShowCursor;
TextAttr := SaveAttr;
End;

END. {of unit}