home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / toolkid / menubox.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-04-05  |  4.7 KB  |  164 lines
  1. UNIT MENUBOX;
  2.  
  3. INTERFACE
  4. USES IOSTUFF,CRT,DOS;
  5.   PROCEDURE ResetBox;
  6.   PROCEDURE SetMenuBox(X,Y : Integer; MenuStr : LongStr);
  7.   FUNCTION PickMenuBox : Char;
  8.  
  9. IMPLEMENTATION
  10.  
  11. CONST
  12.   ColorF1   = Yellow;      { Menu Phrase colors }
  13.   ColorB1   = Blue;
  14.   ColorF2   = LightCyan;   { Foreground Color - First Letter }
  15.   ColorB2   = Blue;
  16.   ColorF3   = Black;       { Reverse Video colors for bar cursor }
  17.   ColorB3   = LightGray;
  18.   ColorF4   = LightGray;     { Border Colors }
  19.   ColorB4   = Black;
  20.   MaxMenuItems = 12;
  21.  
  22. VAR
  23.   XPos,YPos : Integer;
  24.   MenuMsg   : Array[1..MaxMenuItems] of ShortStr; { Make this longer if needed }
  25.   MenuLtr   : Array[1..MaxMenuItems] of Char;
  26.   NumPicks  : Integer;
  27.   Pick      : Integer;
  28.   LastPick  : Integer;
  29.   Longest   : Integer;
  30.   SaveAttr  : Byte;
  31. {============================================================================}
  32. PROCEDURE ResetBox;
  33.  
  34. { Writes the box menu on the screen }
  35.  
  36. VAR
  37.     P : Integer;
  38. BEGIN
  39.     SaveAttr := TextAttr;
  40.     SetColor(ColorF4,ColorB4);
  41.     SBorder(XPos,YPos,XPos+Longest+3,YPos+NumPicks+1,'');
  42.     For P := 1 to NumPicks do Begin
  43.       FillChar(MenuMsg[P,Length(MenuMsg[P])+1],Longest-Length(MenuMsg[P]),' ');
  44.       MenuMsg[P,0] := Chr(Longest);
  45.       SetColor(ColorF1,ColorB1);
  46.       WriteSt(' '+MenuMsg[P]+' ',XPos+1,YPos+P);
  47.       SetColor(ColorF2,ColorB2);
  48.       WriteCh(MenuLtr[P],XPos+2,YPos+P);
  49.     End;
  50.     TextAttr := SaveAttr;
  51. END;
  52. {============================================================================}
  53.   PROCEDURE SetMenuBox(X,Y : Integer; MenuStr : LongStr);
  54.  
  55.   VAR
  56.     CPos   : Integer;
  57.     Len    : Integer;
  58.  
  59.   BEGIN
  60.     XPos := X; YPos := Y;
  61.     Pick := 1;
  62.     LastPick := 1;
  63.     CPos := 1;
  64.     NumPicks := 0;
  65.     Longest := 1;
  66.  
  67.     Repeat
  68.       If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
  69.       Len := Pos('/',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
  70.       MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
  71.       MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
  72.  
  73.  
  74.       If Length(MenuMsg[NumPicks]) > Longest
  75.         then Longest := Length(MenuMsg[NumPicks]);
  76.       CPos := CPos+Len+1;
  77.     Until CPos >= Length(MenuStr);
  78.     ResetBox;
  79.   END;
  80.  
  81. {============================================================================}
  82.   FUNCTION PickMenuBox : Char;
  83.  
  84. CONST
  85.      UpArrow   = #72;
  86.      Downarrow = #80;
  87.      EnterKey  = #13;
  88.      EscKey    = #27;
  89.      Abort     = #0;
  90. VAR
  91.   Err,II    : Integer;
  92.   Ch        : Char;
  93.   PickExit  : Boolean;
  94.   BeepOn    : Boolean;
  95.   FunctKey  : Boolean;
  96.  
  97. BEGIN
  98.  SaveAttr := TextAttr;       { Save the current colors }
  99.  HideCursor;                 { Hide the cursor }
  100.  PickExit := False;
  101.  SetColor(ColorF3,ColorB3);
  102.  
  103.                              { Write the first pick in reverse }
  104.   WriteSt(' '+MenuMsg[Pick]+' ',XPos+1,YPos+Pick);
  105.  
  106.   Repeat     { Main keystroke reading loop -- continue until enter or escape }
  107.  
  108.      Ch := Readkey;     { Read a key }
  109.      If Ch  <> #0 then FunctKey := False else
  110.      Begin
  111.        Ch := ReadKey;
  112.        FunctKey := True;
  113.      End;
  114.  
  115.  
  116.   If not FunctKey then Case Ch of     { Handle non function keys here }
  117.     #32..#125: Begin                  { Check characters against 1st letters }
  118.                 BeepOn := True;
  119.                  For II := 1 to NumPicks do Begin
  120.                    If UpCase(Ch) = MenuLtr[II] then Begin   { got a match }
  121.                       Pick := II;
  122.                       PickExit := True;
  123.                       BeepOn := False;
  124.                    End;
  125.                  End;
  126.                 If BeepOn then Beep;
  127.                End;
  128.     EnterKey,EscKey : PickExit := True;  { Get ready to exit }
  129.  
  130.    End; {case not functkey}
  131.  
  132.   If FunctKey then  Case Ch of     { Handle function keys here }
  133.        UpArrow   : Pick := Pred(Pick);  { Move up one }
  134.        DownArrow : Pick := Succ(Pick);  { Move down one }
  135.        Else Beep;
  136.  
  137.      End; {case functkey}
  138.  
  139.  
  140.    If Pick > NumPicks then Pick := 1;    { Make sure Pick in bounds }
  141.    If Pick < 1 then Pick := NumPicks;
  142.  
  143.    If Pick <> LastPick then Begin
  144.      SetColor(ColorF1,ColorB1);            { Restore last pick }
  145.      WriteSt(' '+MenuMsg[LastPick]+' ',XPos+1,YPos+LastPick);
  146.      SetColor(ColorF2,ColorB2);            { Restore 1st letter last pick }
  147.      WriteCh(MenuLtr[LastPick],XPos+2,YPos+LastPick);
  148.  
  149.      SetColor(ColorF3,ColorB3);            { Highlight new pick in reverse }
  150.      WriteSt(' '+MenuMsg[Pick]+' ',XPos+1,YPos+Pick);
  151.  
  152.      LastPick := Pick;
  153.    End;
  154.  
  155.  Until PickExit;
  156.  
  157.  If Ch = EscKey then PickMenuBox := Abort    { set function to #0 }
  158.                 else PickMenuBox := MenuLtr[Pick];  {set function to letter }
  159.  ShowCursor;
  160.  TextAttr := SaveAttr;   { Restore colors }
  161. End;
  162.  
  163. END. {of unit}
  164.