home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Pascal / MAXONPASCAL3.DMS / in.adf / DEMOS-OS2.0 / Menu.p < prev    next >
Encoding:
Text File  |  1994-08-25  |  8.0 KB  |  224 lines
  1. { Programm:   Menu
  2.   ~~~~~~~~~
  3.   Sprache:    MaxonPASCAL 3 / KickPascal 2.12 & OS 2.0-Includes
  4.   ~~~~~~~~    
  5.  
  6.   ©:          FREEWARE, wenn Autor in Infofenster des jeweiligen Programmes
  7.   ~~          erwähnt und selbiges ihm zugesendet wird.
  8.               Vertrieb nur auf PURITY zulässig.
  9.  
  10.   Sinn:       Gadtoolsmenu umgesetzt (siehe Kommentar)
  11.   ~~~~~       Stringgadget mit "StringA_exitHelp"-Tag
  12.               .exe von Shell starten oder aus Editor.
  13.  
  14.   Autor:      PackMAN
  15.   ~~~~~~      c/o Falk Zühlsdorff
  16.               Lindenberg 66
  17.               D-98693 Ilmenau/Thüringen
  18.  
  19.   Kommentar:  Version für MAXON
  20.   ~~~~~~~~~~  ab OS 2.0                    }
  21.  
  22. Program menutest;
  23.  
  24. USES INTUITION,GRAPHICS,GADTOOLS;
  25. {$INCL 'intuition/intuition_functions.h'}            {{from MP3}}
  26.  
  27. TYPE  MenuType          = array[0..15] OF NewMenu;
  28. VAR   PScr              : p_screen;
  29.       drawinfo          : p_drawinfo;
  30.       txattr            : TextAttr;STATIC;
  31.       font              : p_textfont;
  32.       ysize,ScrTextFont,
  33.       Winbreite         : word;STATIC;
  34.       baseline          : word;STATIC;
  35.       Wbr               : integer;STATIC;
  36.       ourfont           : long;STATIC;
  37.       ex,help           : boolean;STATIC;
  38.       Win               : ^Window;                       {fs. Win}
  39.       RP                : ^RastPort;
  40.       msg               : ^IntuiMessage;
  41.       akt               : ^Gadget;
  42.       NWTags            : array[1..13] OF tagitem;STATIC;
  43.       titel             : string;STATIC;
  44.       pgad,glist        : p_Gadget;
  45.       vi                : PTR;
  46.       fontname          : string;STATIC;
  47.  
  48.       {**************}
  49.       ng                : NewGadget;STATIC;
  50.       g                 : p_Gadget;STATIC;
  51.       STx               : string;STATIC;                    {STR-Gad}
  52.       STags             : array[0..4] OF TagItem;STATIC;
  53.       StrAkt            : boolean;STATIC;
  54.       sig               : ^stringinfo;
  55.  
  56.       {++++++++++++++}
  57.  
  58.       MTags             : array[0..1] of TagItem;STATIC;    {Menu}
  59.       menue             : MenuType;STATIC;
  60.       menustrip         : p_menu;
  61.       formenu,Done      : boolean;STATIC;
  62.       menuNumber,
  63.       menuenum,itemnumb,
  64.       subnumb           : word;
  65.       item              : p_MenuItem;
  66. {-------------------------------------------------------------------------}
  67. BEGIN
  68.  PScr:=NIL;
  69.  PScr:=lockpubscreen(NIL);
  70.  IF PScr<>NIL THEN
  71.   BEGIN
  72.    drawinfo:=getscreendrawinfo(PScr);
  73.     IF drawinfo<>NIL THEN
  74.      BEGIN
  75.       font:=drawinfo^.dri_font;
  76.       ysize:=font^.tf_ysize;
  77.       ScrTextFont:=ysize;
  78.       baseline:=font^.tf_baseline;
  79.       Wbr:=textlength(^PScr^.rastport,'W',1);
  80.       Winbreite:=textlength(^PScr^.rastport,'W',1)*50;
  81.       vi:=GetVisualinfoA(PScr,nil);
  82.       freescreendrawinfo(PScr,drawinfo);
  83.       UnlockPubScreen(NIL,PScr);
  84.       Pgad:=NIL;
  85.       Pgad:=CreateContext(^Glist);
  86.       IF pgad<>nil
  87.        THEN
  88.         BEGIN
  89.          fontname:=drawinfo^.dri_font^.tf_Message.mn_Node.ln_Name;
  90.          txattr:=TextAttr(fontname,ysize,0,0);
  91.         END;
  92.  
  93.       STx:='';
  94.  
  95.       STags[0]:=TagItem(GT_Underscore,ord('_'));
  96.       STags[1]:=TagItem(GTST_MaxChars,20);
  97.       STags[2]:=TagItem(STRINGA_ExitHelp,ord(true));
  98.       STags[3]:=TagItem(GTST_String,long(^STx));
  99.       STags[4].ti_tag:=Tag_Done;
  100.  
  101.       ng:=NewGadget(13*Wbr,ScrTextFont+ysize,23*Wbr,ysize+6,'An_wahl:',
  102.                     ^txattr,0,PLACETEXT_LEFT,vi,nil);
  103.       pgad:=CreateGadgetA(STRING_KIND,pgad,^ng,^STags[0]);
  104.       g:=pgad;
  105.  
  106.       {*** Menu: entries using from RKRM_Libs***}
  107.  
  108.       MTags[0]:=TagItem(GTMN_textAttr,long(^txattr));
  109.       MTags[1].ti_tag:=Tag_END;
  110.  
  111.       Menue:=MenuType(
  112.       NewMenu(NM_TITLE,0,'Project',       NIL,0,0,NIL),
  113.       NewMenu(NM_ITEM, 0,'Open...',      'O', 0,0,NIL),
  114.       NewMenu(NM_ITEM, 0,'Save',         'S', 0,0,NIL),
  115.       NewMenu(NM_ITEM, 0,STR(NM_BARLABEL),NIL,0,0,NIL),
  116.       NewMenu(NM_ITEM, 0,'Print',         NIL,0,0,NIL),
  117.       NewMenu(NM_SUB,  0,'Draft',         NIL,0,0,NIL),
  118.       NewMenu(NM_SUB,  0,'NLQ',           NIL,0,0,NIL),
  119.       NewMenu(NM_ITEM, 0,STR(NM_BARLABEL),NIL,0,0,NIL),
  120.       NewMenu(NM_ITEM, 0,'Quit...',      'Q', 0,0,NIL),
  121.  
  122.       NewMenu(NM_TITLE,0,'Edit',          NIL,0,0,NIL),
  123.       NewMenu(NM_ITEM, 0,'Cut',          'X', 0,0,NIL),
  124.       NewMenu(NM_ITEM, 0,'Copy',         'C', 0,0,NIL),
  125.       NewMenu(NM_ITEM, 0,'Paste',        'V', 0,0,NIL),
  126.       NewMenu(NM_ITEM, 0,STR(NM_BARLABEL),NIL,0,0,NIL),
  127.       NewMenu(NM_ITEM, 0,'Undo',         'Z', 0,0,NIL),
  128.       NewMenu(NM_END,  0,NIL,             NIL,0,0,NIL));        {15}
  129.  
  130.  
  131.       titel:='Menütest 0.10 by PackMAN';
  132.  
  133.        NWTags[1] :=Tagitem(wa_left,0);
  134.        NWTags[2] :=Tagitem(wa_top,0);
  135.        NWTags[3] :=Tagitem(wa_width,Winbreite);
  136.        NWTags[4] :=Tagitem(wa_height,ScrTextFont+8*ysize);
  137.        NWTags[5] :=Tagitem(wa_activate,ord(true));
  138.        NWTags[6] :=Tagitem(wa_smartrefresh,ord(true));
  139.        NWTags[7] :=Tagitem(wa_title,long(^titel));
  140.        NWTags[8] :=Tagitem(wa_Flags,WFLG_CLOSEGADGET+WFLG_DRAGBAR+
  141.                                     WFLG_DEPTHGADGET);
  142.        NWTags[9] :=Tagitem(wa_idcmp,IDCMP_GADGETUP+IDCMP_RAWKEY+
  143.                                     IDCMP_MENUPICK+IDCMP_CLOSEWINDOW);
  144.        NWTags[10] :=Tagitem(wa_Gadgets,long(glist));
  145.        NWTags[11]:=Tagitem(tag_done,0);
  146.  
  147.        Win:=openwindowtaglist(nil,^NWTags[1]);
  148.        IF Win<>NIL THEN
  149.         BEGIN
  150.          RP:=Win^.RPort;
  151.          ourfont:=setfont(RP,font);
  152.  
  153.         menustrip:=CreateMenusA(^menue[0],^MTags[1]);
  154.         formenu:=LayoutMenusA(menustrip,vi,^MTags[0]);
  155.         formenu:=SetMenuStrip(win,menustrip);
  156.  
  157.          ex:=false;
  158.          REPEAT
  159.           Msg:=Wait_Port(Win^.UserPort);
  160.           Msg:=GT_GetIMsg(Win^.UserPort);
  161.           IF Msg<>NIL THEN
  162.            BEGIN
  163.             GT_ReplyIMsg(Msg);
  164.             CASE Msg^.Class OF
  165.              IDCMP_MENUPICK:
  166.               BEGIN
  167.                menuNumber:=Msg^.code;     { Etwas anders als in RKRM_Libs }
  168.                done:=false;               { da sonst mit Gadgets Probleme }
  169.                                           { oder sogar Programmabstürze   }
  170.                IF menuNumber<>MENUNULL    { möglich sind, PackMAN         }
  171.                 THEN
  172.                  REPEAT
  173.                   item:=ItemAddress(menustrip,menuNumber);
  174.                   menueNum:=MENUNUM(MenuNumber);
  175.                   itemNumb:=ITEMNUM(MenuNumber);
  176.                   subNumb :=SUBNUM(MenuNumber);
  177.                   CASE menueNum OF
  178.                    0: CASE ITEMNUMB OF
  179.                        0: BEGIN writeln('Open'); Done:=true;END;
  180.                        1: BEGIN writeln('Save'); Done:=true;END;
  181.                        3: IF subNumb=0
  182.                            THEN BEGIN writeln('Draft');    Done:=true;END
  183.                            ELSE BEGIN writeln('NLQ');      Done:=true;END;
  184.                        5: BEGIN writeln('Quit'); ex:=true; Done:=true;END;
  185.                       ELSE;END;
  186.                    1: CASE ITEMNUMB OF
  187.                        0: BEGIN writeln('Cut');   Done:=true;END;
  188.                        1: BEGIN writeln('Copy');  Done:=true;END;
  189.                        2: BEGIN writeln('Paste'); Done:=true;END;
  190.                        4: BEGIN writeln('Undo');  Done:=true;END;
  191.                      ELSE;END;
  192.                   ELSE;END;
  193.                   IF NOT Done THEN menuNumber:=item^.nextselect;
  194.                  UNTIL Done;
  195.               END;
  196.  
  197.              IDCMP_CLOSEWINDOW: ex:=true;
  198.  
  199.              IDCMP_GADGETUP:
  200.               BEGIN
  201.                Akt:=Msg^.IAddress;
  202.                case AKT^.GADGETID of
  203.                 0  : BEGIN IF Msg^.code= $5F THEN writeln('Help')
  204.                                              ELSE writeln('RETURN');END;
  205.                else;end;
  206.               END;
  207.              IDCMP_RAWKEY:
  208.                IF Msg^.code= $11 THEN strakt:=ACTIVATEGADGET(g,Win,NIL);    {W}
  209.             ELSE;END;
  210.            END;
  211.           UNTIL ex;
  212.          ClearMenuStrip(Win);
  213.          FreeMenus(menustrip);
  214.          CloseWindow(Win);
  215.         END;
  216.          FreeGadgets(glist);
  217.          FreeVisualInfo(vi);
  218.          closelib(gadtoolsbase);
  219.          closelib(gfxbase);
  220.          closelib(Intuitionbase);
  221.      END;
  222.   END;
  223. END.
  224.