home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / demos / gtmenu.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-23  |  4.6 KB  |  147 lines
  1. Program GadtoolsMenu;
  2.  
  3. {* gadtoolsmenu.p
  4. ** Example showing the basic usage of the menu system with a window.
  5. ** Menu layout is done with GadTools, as is recommended for applications.
  6. **
  7. *}
  8.  
  9. uses Exec, Intuition, Utility, GadTools;
  10.  
  11. {$I tagutils.inc}
  12.  
  13. const
  14.  
  15.     mynewmenu : array[0..15] of tNewMenu = (
  16.     (nm_Type: NM_TITLE; nm_Label:'Project';   nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  17.     (nm_Type: NM_ITEM;  nm_Label:'Open...';   nm_CommKey:'O';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  18.     (nm_Type: NM_ITEM;  nm_Label:'Save';      nm_CommKey:'S';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  19.     (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  20.  
  21.     (nm_Type: NM_ITEM;  nm_Label:'Print';     nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  22.     (nm_Type: NM_SUB;   nm_Label:'Draft';     nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  23.     (nm_Type: NM_SUB;   nm_Label:'NLQ';       nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  24.     (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  25.  
  26.     (nm_Type: NM_ITEM;  nm_Label:'Quit...';   nm_CommKey:'Q';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  27.  
  28.     (nm_Type: NM_TITLE; nm_Label:'Edit';      nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  29.     (nm_Type: NM_ITEM;  nm_Label:'Cut';       nm_CommKey:'X';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  30.     (nm_Type: NM_ITEM;  nm_Label:'Copy';      nm_CommKey:'C';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  31.     (nm_Type: NM_ITEM;  nm_Label:'Paste';     nm_CommKey:'V';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  32.     (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  33.  
  34.     (nm_Type: NM_ITEM;  nm_Label:'Undo';      nm_CommKey:'Z';   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL),
  35.  
  36.     (nm_Type:   NM_END; nm_Label:NIL;         nm_CommKey:NIL;   nm_Flags:0; nm_MutualExclude:0; nm_UserData:NIL));
  37.  
  38. var
  39.    win : pWindow;
  40.    myVisualInfo : Pointer;
  41.    menuStrip : pMenu;
  42.    tags : array[0..6] of tTagItem;
  43.    msg  : pMessage;
  44.    done : boolean;
  45.  
  46. Procedure Die;
  47. begin
  48.     if MenuStrip <> nil then begin
  49.        ClearMenuStrip(win);
  50.        FreeMenus(MenuStrip);
  51.     end;
  52.     if myVisualInfo <> nil then FreeVisualInfo(myVisualInfo);
  53.     if win <> Nil then CloseWindow(win);
  54.     if GadToolsBase <> nil then CloseLibrary(GadToolsBase);
  55.     Halt(0);
  56. end;
  57.  
  58.  
  59.  
  60.  
  61. {*
  62. ** Watch the menus and wait for the user to select the close gadget
  63. ** or quit from the menus.
  64. *}
  65. PROCEDURE ProcessIDCMP;
  66. VAR
  67.     IMessage    : tIntuiMessage;
  68.     IPtr    : pIntuiMessage;
  69.  
  70.     Procedure ProcessMenu;
  71.     var
  72.     MenuNumber  : Word;
  73.     ItemNumber  : Word;
  74.     SubItemNumber   : Word;
  75.  
  76.     begin
  77.     if IMessage.Code = MENUNULL then
  78.         Exit;
  79.  
  80.     MenuNumber := MenuNum(IMessage.Code);
  81.     ItemNumber := ItemNum(IMessage.Code);
  82.     SubItemNumber := SubNum(IMessage.Code);
  83.  
  84.     if (MenuNumber = 0) and (ItemNumber = 5) then done := true;
  85.     end;
  86.  
  87. begin
  88.     IPtr := pIntuiMessage(Msg);
  89.     IMessage := IPtr^;
  90.     ReplyMsg(Msg);
  91.  
  92.     case IMessage.IClass of
  93.       IDCMP_MENUPICK    : ProcessMenu;
  94.       IDCMP_CLOSEWINDOW : done := True;
  95.     end;
  96. end;
  97.  
  98. {*
  99. ** Open all of the required libraries and set-up the menus.
  100. *}
  101.  
  102. begin
  103.     GadToolsBase := OpenLibrary(PChar('gadtools.library'#0), 37);
  104.     if GadToolsBase = nil then die;
  105.  
  106.     tags[0] := TagItem(WA_Width,  400);
  107.     tags[1] := TagItem(WA_Activate,    1);
  108.     tags[2] := TagItem(WA_Height, 100);
  109.     tags[3] := TagItem(WA_CloseGadget, 1);
  110.     tags[4] := TagItem(WA_Title,  Long(PChar('Menu Test Window'#0)));
  111.     tags[5] := TagItem(WA_IDCMP,  IDCMP_CLOSEWINDOW or IDCMP_MENUPICK);
  112.     tags[6].ti_Tag := TAG_END;
  113.     win := OpenWindowTagList(NIL, @tags);
  114.     if win = nil then die;
  115.  
  116.     myVisualInfo := GetVisualInfoA(win^.WScreen,nil);
  117.     if myVisualInfo = nil then die;
  118.  
  119.     {
  120.       make the barlabels
  121.     }
  122.     mynewmenu[3].nm_Label := PChar(NM_BARLABEL);
  123.     mynewmenu[7].nm_Label := PChar(NM_BARLABEL);
  124.     mynewmenu[13].nm_Label := PChar(NM_BARLABEL);
  125.  
  126.     if pExecBase(_ExecBase)^.LibNode.Lib_Version >= 39 then begin
  127.         tags[0] := TagItem(GTMN_FrontPen, 1);
  128.         tags[1].ti_Tag := TAG_END;
  129.         MenuStrip := CreateMenusA(@mynewmenu,@tags);
  130.     end else MenuStrip := CreateMenusA(@mynewmenu,NIL);
  131.  
  132.     if menuStrip = nil then die;
  133.  
  134.     if not LayoutMenusA(menuStrip, myVisualInfo,nil) then die;
  135.  
  136.     if not SetMenuStrip(win,menuStrip) then die;
  137.  
  138.     repeat
  139.     Msg := WaitPort(win^.UserPort);
  140.     Msg := GetMsg(win^.UserPort);
  141.        ProcessIDCMP;
  142.     until done;
  143.     die;
  144. end.
  145.  
  146.  
  147.