home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / toolkid / menupull.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-05-23  |  17.6 KB  |  512 lines
  1. UNIT MENUPULL;
  2.  
  3. INTERFACE
  4. USES IoStuff, CRT,DOS;
  5. PROCEDURE RestoreWorkScreen;
  6. PROCEDURE SaveWorkScreen;
  7. PROCEDURE SetMain(MenuStr:AnyStr);
  8. PROCEDURE SetSub(Sub:Integer;SubStr:LongStr);
  9. PROCEDURE WriteSub(Sub:Integer);
  10. PROCEDURE WriteMain;
  11. PROCEDURE RebuildIt;
  12. FUNCTION  PickSub(Sub:Integer) : Char;
  13. FUNCTION  PickMain : Char;
  14.  
  15. IMPLEMENTATION
  16.  
  17. CONST
  18.   ColorF1   = Yellow;     { Menu Colors }
  19.   ColorB1   = Blue;
  20.   ColorF2   = LightCyan;  { First Letter Colors }
  21.   ColorB2   = Blue;
  22.   ColorF3   = Black;      { Reverse Video bar cursor }
  23.   ColorB3   = LightGray;
  24.   ColorF4   = LightGray;  { Border around submenu }
  25.   ColorB4   = Black;
  26.   MaxMenuItems    = 12;
  27.   MaxSubMenuItems = 12;
  28.   Sp              = 3;    { Number of additional pad spaces between  }
  29.                           { menu picks.  Sp = 3 gives 4 spaces total }
  30.  
  31.   XPos = 1; YPos = 1;     { Position of main menu. 1st pick padded with Sp above }
  32.  
  33. VAR
  34.  
  35.   MenuMsg   : Array[1..MaxMenuItems] of ShortStr;      { Main menu messages }
  36.   MenuLtr   : Array[1..MaxMenuItems] of Char;        { 1st letter of Main }
  37.   SubMenuMsg: Array[1..MaxMenuItems,                 { Sub menu messages }
  38.                     1..MaxSubMenuItems] of ShortStr;
  39.   SubMenuLtr: Array[1..MaxMenuItems,                 { Sub menu 1st letter }
  40.                     1..MaxSubMenuItems] of Char;
  41.   MenuOfs   : Array[1..MaxMenuItems] of Integer;     { Offset of main menu }
  42.   NumPicks  : Integer;                               { Number of main picks }
  43.   NumSubs   : Array[1..MaxMenuItems] of Integer;     { Number of sub picks }
  44.   Longest   : Array[1..MaxMenuItems] of Integer;     { longest string in subs }
  45.   Pick      : Integer;                     { Current main pick }
  46.   LastPick  : Integer;                     { Last main pick }
  47.   XP1,YP1   : Integer;                     { top left of submenu location }
  48.   XP2,YP2   : Integer;                     { bottom right of submenu location }
  49.   SPick     : Integer;                     { Current submenu pick }
  50.   LastSPick : Integer;                     { Last submenu pick }
  51.   WorkScreen : Screen;      { Used to save screen contents -- see IOStuff }
  52.   MenuScreen : Screen;      { Used to save screen contents -- see IOStuff }
  53.   RebuildMenu : Boolean;    { Switch to rebuild menu over new screen }
  54.   JustWroteSub: Boolean;    { Switch to skip rewriting submenu }
  55.   FirstTime   : Boolean;    { Used to skip some cleanup logic first time thru }
  56.  
  57. {============================================================================}
  58. PROCEDURE RestoreWorkScreen;
  59.  
  60. { Restores the working screen to its appearance at the last SaveWorkScreen }
  61.  
  62.  BEGIN
  63.   If Color then MoveToScreen(WorkScreen,CS,4000)
  64.            else Move(WorkScreen,MS,4000);
  65.  END;
  66.  
  67. {============================================================================}
  68. PROCEDURE SaveWorkScreen;
  69.  
  70. { Saves a new working screen.  Should be called in the main program }
  71. { any time you fiddle with the screen and want to save it }
  72.  
  73.  BEGIN
  74.   If Color then MoveFromScreen(CS,WorkScreen,4000)
  75.            else Move(MS,WorkScreen,4000);
  76.  
  77.   JustWroteSub := false;         { set these switches to rebuild menu }
  78.   RebuildMenu := true;
  79.  
  80.  END;
  81.  
  82. {============================================================================}
  83. PROCEDURE RestoreMenuScreen;
  84. { Used to save the contents of the screen after the main menu line written }
  85.  
  86.  BEGIN
  87.   If Color then MoveToScreen(MenuScreen,CS,4000)
  88.            else Move(MenuScreen,MS,4000);
  89.  END;
  90.  
  91. {============================================================================}
  92. PROCEDURE SaveMenuScreen;
  93. { Restores the screen to its appearance after the main menu line written }
  94.  
  95.  BEGIN
  96.   If Color then MoveFromScreen(CS,MenuScreen,4000)
  97.            else Move(MS,MenuScreen,4000);
  98.  END;
  99.  
  100. {============================================================================}
  101. PROCEDURE RebuildIt;
  102. { Flips the switches that trigger a complete rebuild of menus }
  103. { This is more efficient when you don't care if the screen is saved }
  104.  
  105.  BEGIN
  106.   JustWroteSub := false;         { set these switches to rebuild menu }
  107.   RebuildMenu := true;
  108.  END;
  109.  
  110. {============================================================================}
  111.   PROCEDURE SetMain(MenuStr:AnyStr);
  112.  
  113. { This Procedure sets the main (bar) menu.  Menu contents are contained in  }
  114. { string MenuStr and are delimited by an /.  Don't forget the last / }
  115.  
  116.   VAR
  117.     CPos     : Integer;       { Parsing variables }
  118.     Len,II   : Integer;
  119.     SaveAttr : Byte;
  120.  
  121.   BEGIN
  122.     SaveAttr := TextAttr;    { Save the colors }
  123.     Pick := 1;               { 1st pick }
  124.     LastPick := 1;
  125.     CPos := 1;
  126.     NumPicks := 0;
  127.     FirstTime := true;
  128.     SaveWorkScreen;         { Save the screen for restoration later }
  129.                             { SaveWorkScreen also triggers rebuild }
  130.     Repeat                  { Parse the main menu string }
  131.  
  132.       If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
  133.                           { Find next substring delimited by an / }
  134.       Len := Pos('/',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
  135.                           { copy the substring into menu message array }
  136.       MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
  137.                           { get the first letter of the menu message }
  138.       MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
  139.                           { Calc menu offset.  Sp is pad spaces between picks}
  140.       MenuOfs[NumPicks] := CPos+Sp*(NumPicks);
  141.  
  142.       NumSubs[NumPicks] := 0;     {Initialize number of sub picks under this pick }
  143.  
  144.       CPos := CPos+Len+1;         { move parsing position to next substring }
  145.     Until CPos >= Length(MenuStr);
  146.  
  147.     TextAttr := SaveAttr;                              { restore colors }
  148.  
  149.   END;
  150.  
  151. {============================================================================}
  152.   PROCEDURE SetSub(Sub:Integer;SubStr:LongStr);
  153.  
  154. { This Procedure sets the sub menu.  Menu contents are contained in   }
  155. { string SubStr and are delimited by an /.  Don't forget the last /. }
  156. { Variable Sub is the number of the main menu the SubStr goes with }
  157.  
  158.   VAR
  159.     CPos,P,Len : Integer;
  160.  
  161.   BEGIN
  162.     CPos := 1;                  { Initialization }
  163.     NumSubs[Sub] := 0;
  164.     Longest[Sub] := 0;
  165.     Repeat           { String Parsing loop }
  166.                      { First increment the number of menu picks }
  167.       If NumSubs[Sub] < MaxMenuItems then NumSubs[Sub] := NumSubs[Sub] + 1;
  168.                      { Get the next substring delimited by a / }
  169.       Len := Pos('/',Copy(SubStr,CPos,Length(SubStr)+1-CPos))-1;
  170.                      { Copy the substring into the menu message }
  171.       SubMenuMsg[Sub,NumSubs[Sub]] := Copy(SubStr,CPos,Len);
  172.                      { Get the first letter }
  173.       SubMenuLtr[Sub,NumSubs[Sub]] := UpCase(SubMenuMsg[Sub,NumSubs[Sub],1]);
  174.                      { Remember the longest string length for padding later }
  175.       If Length(SubMenuMsg[Sub,NumSubs[Sub]]) > Longest[Sub]
  176.         then Longest[Sub] := Length(SubMenuMsg[Sub,NumSubs[Sub]]);
  177.       CPos := CPos+Len+1;            { Move parsing position to next string }
  178.     Until CPos >= Length(SubStr);    { End of parsing loop }
  179.  
  180.     For P := 1 to NumSubs[Sub] do Begin    { pad all strings to same length }
  181.       Len := Length(SubMenuMsg[Sub,P]);
  182.       FillChar(SubMenuMsg[Sub,P,Len+1],Longest[Sub]-Len,' '); { Pad with blanks }
  183.       SubMenuMsg[Sub,P,0] := Chr(Longest[Sub]);               { reset length }
  184.     End;
  185.  
  186.    SPick := 1;                 { Initialize submenu pick index here }
  187.    LastSPick := 1;
  188.  
  189.   END;
  190.  
  191. {============================================================================}
  192.   PROCEDURE WriteSub(Sub:Integer);
  193.  
  194. { This Procedure writes out the submenu }
  195.  
  196.   VAR
  197.     II       : Integer;
  198.     SaveAttr : Byte;
  199.  
  200.   BEGIN
  201.     If NumSubs[Sub] = 0 then exit;
  202.     SaveAttr := TextAttr;            { Save the color attributes }
  203.     XP1 := XPos+MenuOfs[Sub];
  204.     YP1 := YPos+2;
  205.     XP2 := XPos+MenuOfs[Sub]+Longest[Sub]+1;
  206.     YP2 := YPos+NumSubs[Sub]+1;
  207.     SavePartScreen(XP1-1,YP1-1,XP2+1,YP2+1);
  208.                                      { Draw a single line border }
  209.     SetColor(ColorF4,ColorB4);
  210.     SBorder(XP1-1,YP1-1,XP2+1,YP2+1,'');
  211.  
  212.     For II := 1 to NumSubs[Sub] do begin   { Write the menu messages }
  213.       SetColor(ColorF1,ColorB1);
  214.       WriteSt(' '+SubMenuMsg[Sub,II]+' ',XP1,YP1+II-1);
  215.       SetColor(ColorF2,ColorB2);
  216.       WriteCh(SubMenuLtr[Sub,II],XP1+1,YP1+II-1);
  217.     End;
  218.     TextAttr := SaveAttr;            { Restore the color attributes }
  219.  
  220.   END;
  221.  
  222. {============================================================================}
  223.   PROCEDURE WriteMain;
  224.  
  225. { This Procedure writes out the main menu }
  226.  
  227.   VAR
  228.     II       : Integer;
  229.     SaveAttr : Byte;
  230.   BEGIN
  231.     SaveAttr := TextAttr;        { Save the color attributes }
  232.     SetColor(ColorF1,ColorB1);
  233.     GoToXY(1,YPos);ClrEol;       { Clear the menu line }
  234.  
  235.     For II := 1 to NumPicks do begin  { Write the menu messages }
  236.  
  237.       SetColor(ColorF1,ColorB1);
  238.       WriteSt(MenuMsg[II],XPos+MenuOfs[II],YPos);  { Write Picks }
  239.       SetColor(ColorF2,ColorB2);
  240.       WriteCh(MenuLtr[II],XPos+MenuOfs[II],YPos);  { Write 1st letter }
  241.     End;
  242.     SaveMenuScreen;       { Save the screen image }
  243.     TextAttr := SaveAttr;
  244.    END;
  245. {============================================================================}
  246.   FUNCTION PickSub(Sub : Integer) : Char;
  247.  
  248. { This Function plays with the submenu and returns the first character }
  249. { of the selected menu item }
  250.  
  251. CONST
  252.      UpArrow   = #72;        { Keystrokes used }
  253.      Downarrow = #80;
  254.      EnterKey  = #13;
  255.      EscKey    = #27;
  256.      Abort     = #0;
  257. VAR
  258.   II        : Integer;       { General purpose loop index }
  259.   Ch        : Char;          { Keystroke character }
  260.   SubExit   : Boolean;       { Exit switch }
  261.   BeepOn    : Boolean;
  262.   FunctKey  : Boolean;       { True if dey is function key }
  263.   ExitCond  : Integer;       { Used for different exit conditions }
  264.   SaveAttr  : Byte;          { Color attributes }
  265.  
  266. BEGIN
  267.  SaveAttr := TextAttr;       { Save the current colors }
  268.  HideCursor;                 { Hide the cursor }
  269.  SubExit := False;          { Initialze exit switch }
  270.  ExitCond := 1;
  271.  If (SPick < 1) or (SPick > NumSubs[Sub]) then SPick := 1;
  272.  If (LastSPick < 1) or (LastSPick > NumSubs[Sub]) then LastSPick := 1;
  273.  
  274. If not JustWroteSub then begin
  275.  
  276.  If RebuildMenu then begin
  277.  
  278.    If not FirstTime then RestoreWorkScreen;
  279.    WriteMain;               { Reconstruct the main menu }
  280.    SetColor(ColorF3,ColorB3);
  281.                             { Rewrite active main menu pick in reverse }
  282.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  283.    WriteSub(Pick); { Reconstruct the submenu }
  284.    RebuildMenu := false;
  285.  End
  286.  else begin
  287.  
  288.    RestoreMenuScreen;
  289.    SetColor(ColorF3,ColorB3);
  290.                             { Rewrite active main menu pick in reverse }
  291.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  292.    WriteSub(Pick); { Reconstruct the submenu }
  293.  End;
  294.  
  295.  
  296. End;
  297.    FirstTime := False;
  298.    JustWroteSub := False;
  299.    SetColor(ColorF3,ColorB3);
  300.                             { Rewrite active sub menu pick in reverse }
  301.    WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
  302.    LastSPick := SPick;
  303.  
  304.  Repeat     { Main keystroke reading loop -- continue until enter or escape }
  305.  
  306.    If SPick <> LastSPick then Begin
  307.                                     { First restore the last pick }
  308.       SetColor(ColorF1,ColorB1);
  309.       WriteSt(' '+SubMenuMsg[Sub,LastSPick]+' ',XPos+MenuOfs[Sub],YPos+LastSPick+1);
  310.       SetColor(ColorF2,ColorB2);
  311.       WriteCh(SubMenuLtr[Sub,LastSPick],XPos+MenuOfs[Sub]+1,YPos+LastSPick+1);
  312.                                     { Highlight new pick in reverse }
  313.       SetColor(ColorF3,ColorB3);
  314.       WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
  315.  
  316.       LastSPick := SPick;            { Set last pick to current pick }
  317.  
  318.    End;
  319.      Ch := Readkey;     { Read a key }
  320.      If Ch  <> #0 then FunctKey := False else
  321.      Begin
  322.        Ch := ReadKey;
  323.        FunctKey := True;
  324.      End;
  325.  
  326.  
  327.   If not FunctKey then Case Ch of     { Handle non function keys here }
  328.     #32..#125: Begin                  { Check input char against 1st letters }
  329.                 BeepOn := True;
  330.                  For II := 1 to NumSubs[Sub] do Begin
  331.                                        { got a match }
  332.                    If UpCase(Ch) = SubMenuLtr[Sub,II] then Begin
  333.                       SPick := II;      { Set pick index to the matched char }
  334.                       SubExit := True; { Turn on exit switch }
  335.                       BeepOn := False;
  336.                    End;
  337.                  End;
  338.                 If BeepOn then Beep;    { You hit a bad character }
  339.                End;
  340.     EnterKey   : Begin                  { Ordinary exit }
  341.                 ExitCond := 1;
  342.                 SubExit := true;
  343.                End;
  344.     EscKey   : Begin                    { Abort exit }
  345.                 ExitCond := 2;
  346.                 SPick := 0;
  347.                 SubExit := true;
  348.                End;
  349.  
  350.    End; {case not functkey}
  351.  
  352.   If FunctKey then  Case Ch of            { Handle function keys here }
  353.        UpArrow   : SPick := Pred(SPick);  { Move up one }
  354.        DownArrow : SPick := Succ(SPick);  { Move down one }
  355.        Else Beep;
  356.  
  357.      End; {case functkey}
  358.  
  359.  
  360.    If SPick > NumSubs[Sub] then SPick := 1;    { Make sure Pick in bounds }
  361.    If SPick < 1 then Begin                     { User exited with up arrow }
  362.                 ExitCond := 2;                 { Handle like abort }
  363.                 SubExit := true;
  364.                End;
  365.  
  366.  
  367.  
  368.  Until SubExit;         { Bottom of big key reading loop }
  369.  
  370.       SetColor(ColorF1,ColorB1);   { Restore last pick on submenu }
  371.       WriteSt(' '+SubMenuMsg[Sub,LastSPick]+' ',XPos+MenuOfs[Sub],YPos+LastSPick+1);
  372.       SetColor(ColorF2,ColorB2);
  373.       WriteCh(SubMenuLtr[Sub,LastSPick],XPos+MenuOfs[Sub]+1,YPos+LastSPick+1);
  374.  
  375.  Case ExitCond of
  376.  2: Begin
  377.       PickSub := Abort;
  378.       JustWroteSub := true;
  379.      End;
  380.  
  381.  1: Begin
  382.       PickSub := SubMenuLtr[Sub,SPick];  {set function to letter }
  383.                                     { Highlight new pick in reverse }
  384.       SetColor(ColorF3,ColorB3);
  385.       WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
  386.  
  387.      JustWroteSub := false;
  388.     End;
  389.  
  390.   End; {case}
  391.                          { Clean up and get out }
  392.  
  393.  ShowCursor;
  394.  TextAttr := SaveAttr;   { Restore colors }
  395. End;
  396.  
  397. {============================================================================}
  398. FUNCTION PickMain : Char;
  399.  
  400. { This Function returns the first character of the main menu item }
  401. { the user selected }
  402.  
  403. CONST
  404.      LeftArrow   = #75;      { Keystrokes used }
  405.      RightArrow  = #77;
  406.      DownArrow   = #80;
  407.      EnterKey    = #13;
  408.      EscKey      = #27;
  409.      Abort       = #0;
  410. VAR
  411.   II        : Integer;       { General purpose loop index }
  412.   Ch        : Char;          { Keystroke read in }
  413.   MainExit  : Boolean;       { Exit switch }
  414.   BeepOn    : Boolean;
  415.   FunctKey  : Boolean;       { True if input char is a function key }
  416.   SaveAttr : Byte;           { Save color attributes }
  417.  
  418. BEGIN
  419.  SaveAttr := TextAttr;       { Initialization }
  420.  MainExit := False;
  421.  HideCursor;
  422.  If (Pick < 1) or (Pick > NumPicks) then Pick := 1;
  423.  If Not JustWroteSub then begin
  424.   If RebuildMenu then begin
  425.  
  426.  
  427.     RestoreWorkScreen;
  428.  
  429.     WriteMain;               { Reconstruct the main menu }
  430.     SetColor(ColorF3,ColorB3);
  431.                              { Rewrite active main menu pick in reverse }
  432.     WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  433.     WriteSub(Pick); { Reconstruct the submenu }
  434.     RebuildMenu := false;
  435.   End
  436.   else begin
  437.     RestoreMenuScreen;
  438.     SetColor(ColorF3,ColorB3);
  439.                              { Rewrite active main menu pick in reverse }
  440.     WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  441.     WriteSub(Pick); { Reconstruct the submenu }
  442.   End;
  443.  
  444. End;
  445.  
  446.  Repeat                     { main keystroke loop }
  447.  
  448.      Ch := Readkey;
  449.      If Ch  <> #0 then FunctKey := False else
  450.      Begin
  451.        Ch := ReadKey;
  452.        FunctKey := True;
  453.      End;
  454.  
  455.  
  456.   If not FunctKey then Case Ch of
  457.     #32..#125: Begin
  458.                 BeepOn := True;
  459.                  For II := 1 to NumPicks do Begin
  460.                    If UpCase(Ch) = UpCase(MenuLtr[II]) then Begin
  461.                       Pick := II;
  462.                       MainExit := True;
  463.                       BeepOn := False;
  464.                    End;
  465.                  End;
  466.                 If BeepOn then Beep;
  467.                End;
  468.     EnterKey,
  469.     EscKey : MainExit := True;
  470.  
  471.    End; {case not functkey}
  472.  
  473.   If FunctKey then  Case Ch of
  474.        LeftArrow   : Pick := Pred(Pick);
  475.        RightArrow  : Pick := Succ(Pick);
  476.        DownArrow   : If NumSubs[Pick] > 0 then MainExit := true else beep;
  477.  
  478.        Else Beep;
  479.  
  480.      End; {case functkey}
  481.  
  482.  
  483.    If Pick > NumPicks then Pick := 1;
  484.    If Pick < 1 then Pick := NumPicks;
  485.  
  486. If Pick <> LastPick then Begin
  487.  
  488.    SetColor(ColorF1,ColorB1);
  489.    WriteSt(' '+MenuMsg[LastPick]+' ',XPos+MenuOfs[LastPick]-1,YPos);  { Write Picks }
  490.    SetColor(ColorF2,ColorB2);
  491.    WriteCh(MenuLtr[LastPick],XPos+MenuOfs[LastPick],YPos);  { Write 1st letter }
  492.    If NumSubs[LastPick] > 0 then RestorePartScreen(XP1-1,YP1-1,XP2+1,YP2+1);
  493.    SetColor(ColorF3,ColorB3);
  494.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);  { Write a new pick }
  495.    WriteSub(Pick);
  496.    LastPick := Pick;
  497.  End;
  498.  
  499.  Until MainExit;
  500.  
  501.  If Ch = EscKey then PickMain := Abort
  502.                 else PickMain := MenuLtr[Pick];
  503.  
  504.  JustWroteSub := true;
  505.  SPick := 1;
  506.  LastSPick := 1;
  507.  ShowCursor;
  508.  TextAttr := SaveAttr;
  509. End;
  510.  
  511. END. {of unit}
  512.