home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / menu / overdriv / menu123.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-04-05  |  4.0 KB  |  158 lines
  1. UNIT MENU123;
  2.  
  3. INTERFACE
  4. USES IOSTUFF,CRT,DOS;
  5.   PROCEDURE Reset123;
  6.   PROCEDURE SetMenu123(X,Y:Integer;MenuStr:AnyStr);
  7.   FUNCTION PickMenu123 : Char;
  8.  
  9. IMPLEMENTATION
  10.  
  11. CONST
  12.   ColorF1   = Yellow;     { Menu Colors }
  13.   ColorB1   = Blue;
  14.   ColorF2   = LightCyan;  { Foreground Color - First Letter }
  15.   ColorB2   = Blue;
  16.   ColorF3   = Black;      { Reverse Video bar cursor }
  17.   ColorB3   = LightGray;
  18.   MaxMenuItems = 12;
  19.   Sp        = 3;          { Number of additional pad spaces between  }
  20.                           { menu picks.  Sp = 3 gives 4 spaces total }
  21. VAR
  22.   XPos,YPos : Integer;
  23.   MenuMsg   : Array[1..MaxMenuItems] of ShortStr; { Make this longer if needed }
  24.   MenuLtr   : Array[1..MaxMenuItems] of Char;
  25.   MenuOfs   : Array[1..MaxMenuItems] of Integer;
  26.   NumPicks  : Integer;
  27.   Pick      : Integer;
  28.   LastPick  : Integer;
  29.   SaveAttr  : Byte;
  30. {============================================================================}
  31.  
  32. PROCEDURE Reset123;
  33. VAR
  34.    P : Integer;
  35. BEGIN
  36.     SaveAttr := TextAttr;
  37.     SetColor(ColorF1,ColorB1);
  38.     GoToXY(1,YPos);ClrEol;
  39.     For P := 1 to NumPicks do begin
  40.       SetColor(ColorF1,ColorB1);
  41.       WriteSt(MenuMsg[P],XPos+MenuOfs[P],YPos);
  42.       SetColor(ColorF2,ColorB2);
  43.       WriteCh(MenuLtr[P],XPos+MenuOfs[P],YPos);
  44.     End;
  45.     TextAttr := SaveAttr;
  46. END;
  47. {============================================================================}
  48.  
  49. PROCEDURE SetMenu123(X,Y:Integer;MenuStr:AnyStr);
  50.  
  51. VAR
  52.     CPos : Integer;
  53.     Len  : Integer;
  54.  
  55.   BEGIN
  56.     XPos := X; YPos := Y;
  57.     Pick := 1;
  58.     LastPick := 1;
  59.     CPos := 1;
  60.     NumPicks := 0;
  61.     Repeat
  62.  
  63.       If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
  64.       Len := Pos('/',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
  65.       MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
  66.       MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
  67.       MenuOfs[NumPicks] := CPos+Sp*(NumPicks-1);
  68.       CPos := CPos+Len+1;
  69.  
  70.     Until CPos >= Length(MenuStr);
  71.     Reset123;
  72.  
  73.   END;
  74.  
  75. {============================================================================}
  76. FUNCTION PickMenu123 : Char;
  77.  
  78. CONST
  79.      LeftArrow   = #75;
  80.      RightArrow  = #77;
  81.      DownArrow   = #80;
  82.      EnterKey    = #13;
  83.      EscKey      = #27;
  84.      Abort       = #0;
  85. VAR
  86.   Err,II    : Integer;
  87.   Ch        : Char;
  88.   PickExit  : Boolean;
  89.   BeepOn    : Boolean;
  90.   FunctKey  : Boolean;
  91.  
  92. BEGIN
  93.  SaveAttr := TextAttr;
  94.  PickExit := False;
  95.  SetColor(ColorF3,ColorB3);
  96.  WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  97.  HideCursor;
  98.  Repeat
  99.  
  100.      Ch := Readkey;
  101.      If Ch  <> #0 then FunctKey := False else
  102.      Begin
  103.        Ch := ReadKey;
  104.        FunctKey := True;
  105.      End;
  106.  
  107.  
  108.   If not FunctKey then Case Ch of
  109.     #32..#125: Begin
  110.                 BeepOn := True;
  111.                  For II := 1 to NumPicks do Begin
  112.                    If UpCase(Ch) = UpCase(MenuLtr[II]) then Begin
  113.                       Pick := II;
  114.                       PickExit := True;
  115.                       BeepOn := False;
  116.                    End;
  117.                  End;
  118.                 If BeepOn then Beep;
  119.                End;
  120.     EnterKey,
  121.     EscKey : PickExit := True;
  122.  
  123.    End; {case not functkey}
  124.  
  125.   If FunctKey then  Case Ch of
  126.        LeftArrow   : Pick := Pick - 1;
  127.        RightArrow : Pick := Pick + 1;
  128.        DownArrow  : PickExit := True;
  129.        Else Beep;
  130.  
  131.      End; {case functkey}
  132.  
  133.  
  134.    If Pick > NumPicks then Pick := 1;
  135.    If Pick < 1 then Pick := NumPicks;
  136.  
  137. If Pick <> LastPick then Begin
  138.    SetColor(ColorF1,ColorB1);
  139.    WriteSt(' '+MenuMsg[LastPick]+' ',XPos-1+MenuOfs[LastPick],YPos);
  140.    SetColor(ColorF2,ColorB2);
  141.    WriteCh(MenuLtr[LastPick],XPos+MenuOfs[LastPick],YPos);
  142.  
  143.    SetColor(ColorF3,ColorB3);
  144.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  145.  
  146.    LastPick := Pick;
  147.  End;
  148.  
  149.  Until PickExit;
  150.  
  151.  If Ch = EscKey then PickMenu123 := Abort
  152.                 else PickMenu123 := MenuLtr[Pick];
  153.  ShowCursor;
  154.  TextAttr := SaveAttr;
  155. End;
  156.  
  157. END. {of unit}
  158.