home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #1 / monster.zip / monster / PROG_PAS / XLIB_TP5.ZIP / UNITS / X_MENU.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-26  |  8KB  |  280 lines
  1. unit X_Menu;
  2.  
  3. (*
  4.     procedures to make a pull-down-menu for mouse and/or keys
  5.  
  6.     ****** XLIB - Mode X graphics library                ****************
  7.     ******                                               ****************
  8.     ****** Converted By Christian Harms in TP            ****************
  9.  
  10.     Harms   : harms@minnie.informatik.uni-stuttgart.de
  11.  
  12. *)
  13.  
  14. interface
  15.  
  16. type  ID_Typ  = Word;
  17.  
  18.       Line_List = ^Line_Typ;
  19.       Line_Typ = record
  20.          next : Line_List;
  21.          ID   : ID_Typ;
  22.          S    : ^String;
  23.          k    : Char;
  24.       end;
  25.  
  26.  
  27.       Menu_Typ = record
  28. {        on_display   : Boolean;}
  29.         x1,y1,x2,y2  : Word;
  30.         c1,c2,c3,sC,TextHi,TextLo  : Byte;
  31.         Line_Count   : Byte;
  32.         max_width    : Word;
  33.         Last_Line    : Byte;
  34.         MouseMask    : Byte;
  35.         SS           : Pointer;
  36.       end;
  37.  
  38.  
  39. (* set values to your M:Menu_Typ
  40.       C1            is the upper,left Shadow
  41.       C2            Background of Menu
  42.       C3            is the lower,right Shadow
  43.       Selected_C    Color of scrollbar
  44.       Text_Hi       Text-Color
  45.       Text_Lo       Shadow of Text
  46.       MouseMask     look in const - part of X_Button                       *)
  47.  
  48. procedure X_Init_Menu(var M:Menu_Typ;                     (* Menu-Variable *)
  49.                       C1,C2,C3,Selected_C,TextHi,TextLo:Byte;    (* Colors *)
  50.                       MouseMask:Byte);                       (* s.X_Button *)
  51.  
  52. (* After X_Init_Menu, you can add some textlines.                          *)
  53. (* For Color Text, see syntax in E_WriteColor in X_Text.                   *)
  54. procedure X_Add_Menu (var M:Menu_Typ;ID:ID_Typ;S:String;KeyChar:Char);
  55.  
  56. (* Deallocate all line of M:Mynu_Typ.                                      *)
  57. procedure X_Kill_Menu(var M:Menu_Typ);
  58.  
  59. (* Draw Menu on Screen.                                                    *)
  60. procedure X_Show_Menu(var M:Menu_Typ;x,y:Word);
  61.  
  62. (* return ID, if in this moment one line selected by mouse , esle return 0.*)
  63. function  Get_Selected_MenuLine(var M:Menu_Typ):ID_Typ;
  64.  
  65. (* wait for selecting any line and return ID, or 0 if breaked by ESC.      *)
  66. (* This works with key or mouse !                                          *)
  67. function  Wait_Selected_MenuLine(var M:Menu_Typ):ID_Typ;
  68.  
  69.  
  70. implementation
  71.  
  72. uses X_Main,X_Rect,X_Text,X_Mouse,x_Keys;
  73.  
  74. procedure X_Init_Menu;
  75. begin;
  76.   M.C1:=C1;M.C2:=C2;M.C3:=C3;M.sC:=Selected_C;
  77.   M.TextHi:=TextHi;M.TextLo:=TextLo;
  78.   M.MouseMask:=MouseMask;
  79. {  M.On_Display:=False;}
  80.   M.SS:=NIL;
  81.   M.Line_Count:=0;
  82.   M.Max_Width:=0;
  83. end;
  84.  
  85. procedure X_Add_Menu(var M:Menu_Typ;ID:ID_Typ;S:String;KeyChar:Char);
  86. var Run,P:Line_List;
  87. begin;
  88.   if M.SS=NIL then
  89.   begin;
  90.     GetMEM(P,sizeof(Line_Typ));
  91.     P^.ID:=ID;
  92.     P^.k :=KeyChar;
  93.     GetMEM(P^.s,length(s)+1);
  94.     P^.S^:=S;
  95.     if x_Length(S)>M.Max_Width then M.Max_Width:=x_Length(S);
  96.     P^.next:=NIL;
  97.     M.SS:=P;
  98.   end         else
  99.   begin;
  100.     Run:=M.SS;
  101.     while (Run^.next<>NIL) do Run:=Run^.next;
  102.     GetMEM(P,sizeof(Line_Typ));
  103.     P^.ID:=ID;
  104.     P^.k :=KeyChar;
  105.     GetMEM(P^.s,length(s)+1);
  106.     P^.S^:=S;
  107.     if x_Length(S)>M.Max_Width then M.Max_Width:=x_Length(S);
  108.     P^.next:=NIL;
  109.     Run^.next:=P;
  110.   end;
  111.   Inc(M.Line_Count);
  112. end;
  113.  
  114. procedure X_Kill_Menu;
  115. var Run,P:Line_List;
  116. begin;
  117.   if M.SS=Nil then Exit;
  118.   Run:=M.SS;
  119.   while (Run<>NIL) do
  120.   begin;
  121.     P:=Run;
  122.     Run:=Run^.next;
  123.     FreeMEM(P^.S,length(P^.S^)+1);
  124.     FreeMEM(P,sizeof(Line_Typ));
  125.   end;
  126.   M.SS:=NIL;
  127. end;
  128.  
  129.   function Get_S(M:Menu_Typ;Nr:Byte):String;
  130.   var Run:Line_List;c:Byte;
  131.   begin;
  132.     C:=1;
  133.     Run:=M.SS;
  134.     while (C<>Nr) do begin;Run:=Run^.next;Inc(C);end;
  135.     Get_S:=Run^.S^;
  136.   end;
  137.  
  138.   function Get_ID(M:Menu_Typ;Nr:Byte):ID_Typ;
  139.   var Run:Line_List;c:Byte;
  140.   begin;
  141.     C:=1;
  142.     Run:=M.SS;
  143.     while (C<>Nr) do begin;Run:=Run^.next;Inc(C);end;
  144.     Get_ID:=Run^.ID;
  145.   end;
  146.  
  147.   function Get_key(M:Menu_Typ;Nr:Byte):Char;
  148.   var Run:Line_List;c:Byte;
  149.   begin;
  150.     C:=1;
  151.     Run:=M.SS;
  152.     while (C<>Nr) do begin;Run:=Run^.next;Inc(C);end;
  153.     Get_key:=Run^.k;
  154.   end;
  155.  
  156.  
  157.  
  158. procedure X_Show_Menu;
  159. var i:Byte;
  160.     j:Word;
  161.     s  :String;
  162. begin;
  163.   with M do
  164.   begin;
  165.     x1:=x;   x2:=Max_Width+x+4;
  166.     y1:=y;   y2:=y+x_font_Height*Line_Count+4;
  167.  
  168.     Shadow_Box(x1+1,y1+1,x2-1,y2-1,C1,C2,C3);
  169.  
  170.     for i:=1 to Line_Count do
  171.       E_WriteColor(x1+2,y1+2+(i-1)*x_font_Height,TextHi,TextLo,center(Max_Width,Get_S(M,i)));
  172.  
  173.     Last_Line:=1;
  174.     Box(x1+2,y1+2,x2-2,y1+1+x_font_Height,SC);
  175.     E_WriteColor(x1+2,y1+2,TextHi,TextLo,center(Max_Width,Get_S(M,1)));
  176.  
  177.   end;
  178. end;
  179.  
  180. procedure New_Line(var M:Menu_Typ;LineOld,LineNew:Byte);
  181. begin;
  182.   with M do
  183.   begin;
  184.       Box(x1+2,y1+2+(LineOld-1)*x_font_Height,x2-2,y1+2+LineOld*x_font_Height,C2);
  185.       E_WriteColor(x1+2,y1+2+(LineOld-1)*x_font_Height,TextHi,TextLo,center(Max_Width,Get_S(M,LineOld)));
  186.  
  187.       Box(x1+2,y1+2+(LineNew-1)*x_font_Height,x2-2,y1+2+LineNew*x_font_Height,SC);
  188.       E_WriteColor(x1+2,y1+2+(LineNew-1)*x_font_Height,TextHi,TextLo,center(Max_Width,Get_S(M,LineNew)));
  189.   end;
  190. end;
  191.  
  192. function  Get_Selected_MenuLine;
  193. var Line:Byte;
  194.     MS:Boolean;
  195. begin;
  196.   with M do
  197.   begin;
  198.     if not InBox(x1,y1,x2,y2) then begin;Get_Selected_MenuLine:=0;exit;end;
  199.     Line:=(MouseY-y1)div x_font_Height+1;
  200.     if (Line>=0)and(Line<=Line_Count)and(Line<>Last_Line) then
  201.     begin;
  202.       MS:=IsMouseHidden;
  203.       if not MS then HideMouse;
  204.       New_Line(M,Last_Line,Line);
  205.       Last_Line:=Line;
  206.       if not MS then ShowMouse;
  207.     end;
  208.     if (ButtonStatus and MouseMask)>0
  209.                             then Get_Selected_MenuLine:=Get_ID(M,Last_Line)
  210.                             else Get_Selected_MenuLine:=0;
  211.   end;
  212. end;
  213.  
  214.  
  215. function Wait_Selected_MenuLine;
  216. var Ok:Boolean;
  217.     erg,i,j:ID_Typ;
  218.     a:Char;
  219. begin;
  220.   Ok:=False;
  221.   erg:=0;
  222.   ShowMouse;
  223.   MouseAction:=False;
  224.   repeat
  225.     if MouseAction then erg:=Get_Selected_MenuLine(M);
  226.     if erg<>0 then Ok:=True;
  227.     if (erg=0) and KeysPressed then
  228.     begin;
  229.       HideMouse;
  230.       a:=UpCase(ReadKeys);
  231.       case a of
  232.         #0:begin;
  233.              a:=ReadKeys;
  234.              case a of
  235.                Up:if M.Last_Line>0 then
  236.                   begin;
  237.                     i:=M.Last_Line-1;
  238.                     if i=0 then i:=M.Line_Count;
  239.                     New_line(M,M.Last_Line,i);
  240.                     M.Last_Line:=i;
  241.                   end;
  242.                Down:If M.Last_Line<=M.Line_Count then
  243.                   begin;
  244.                     i:=M.Last_Line+1;
  245.                     if i>M.Line_Count then i:=1;
  246.                     New_Line(M,M.Last_Line,i);
  247.                     M.Last_Line:=i;
  248.                   end;
  249.              end;
  250.            end;
  251.         Enter,Space:begin;
  252.              erg:=Get_ID(M,M.Last_Line);
  253.              Ok:=True;
  254.            end;
  255.         ESC:begin;
  256.              erg:=0;
  257.              Ok:=True;
  258.            end;
  259.         else begin;          (* search for a hot key , init in x_add_menu *)
  260.              j:=0;
  261.              a:=UpCase(a);
  262.              for i:=1 to M.Line_Count do
  263.                if (Get_key(M,i)=a)or(UpCase(Get_key(M,i))=a) then j:=i;
  264.              if (j>0) then
  265.              begin;
  266.                New_Line(M,M.Last_Line,j);
  267.                M.Last_Line:=j;
  268.              end;
  269.            end;
  270.       end;
  271.       ShowMouse;
  272.       MouseAction:=False;
  273.     end;
  274.  
  275.   until Ok;
  276.   Wait_Selected_MenuLine:=erg;
  277. end;
  278.  
  279. end.
  280.