← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to packages/extra/amunits/demos/gtmenu.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
packages/extra/amunits/demos/gtmenu.pas
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
 
{
10
 
   Changed to use TAGS and pas2c.
11
 
   1 Nov 1998.
12
 
 
13
 
   Updated for systemvartags.
14
 
   28 Nov 2002.
15
 
 
16
 
   nils.sjoholm@mailbox.swipnet.se
17
 
}
18
 
 
19
 
uses Exec, Intuition, Utility, GadTools, systemvartags;
20
 
 
21
 
 
22
 
 
23
 
const
24
 
 
25
 
    mynewmenu : array[0..15] of tNewMenu = (
26
 
    (nm_Type: NM_TITLE; nm_Label:'Project';   nm_CommKey: NIL;  nm_Flags:0; 
27
 
nm_MutualExclude:0; nm_UserData:NIL),
28
 
    (nm_Type: NM_ITEM;  nm_Label:'Open...';   nm_CommKey:'O';   nm_Flags:0; 
29
 
nm_MutualExclude:0; nm_UserData:NIL),
30
 
    (nm_Type: NM_ITEM;  nm_Label:'Save';      nm_CommKey:'S';   nm_Flags:0; 
31
 
nm_MutualExclude:0; nm_UserData:NIL),
32
 
    (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; 
33
 
nm_MutualExclude:0; nm_UserData:NIL),
34
 
 
35
 
    (nm_Type: NM_ITEM;  nm_Label:'Print';     nm_CommKey: NIL;  nm_Flags:0; 
36
 
nm_MutualExclude:0; nm_UserData:NIL),
37
 
    (nm_Type: NM_SUB;   nm_Label:'Draft';     nm_CommKey: NIL;  nm_Flags:0; 
38
 
nm_MutualExclude:0; nm_UserData:NIL),
39
 
    (nm_Type: NM_SUB;   nm_Label:'NLQ';       nm_CommKey: NIL;  nm_Flags:0; 
40
 
nm_MutualExclude:0; nm_UserData:NIL),
41
 
    (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; 
42
 
nm_MutualExclude:0; nm_UserData:NIL),
43
 
 
44
 
    (nm_Type: NM_ITEM;  nm_Label:'Quit...';   nm_CommKey:'Q';   nm_Flags:0; 
45
 
nm_MutualExclude:0; nm_UserData:NIL),
46
 
 
47
 
    (nm_Type: NM_TITLE; nm_Label:'Edit';      nm_CommKey: NIL;  nm_Flags:0; 
48
 
nm_MutualExclude:0; nm_UserData:NIL),
49
 
    (nm_Type: NM_ITEM;  nm_Label:'Cut';       nm_CommKey:'X';   nm_Flags:0; 
50
 
nm_MutualExclude:0; nm_UserData:NIL),
51
 
    (nm_Type: NM_ITEM;  nm_Label:'Copy';      nm_CommKey:'C';   nm_Flags:0; 
52
 
nm_MutualExclude:0; nm_UserData:NIL),
53
 
    (nm_Type: NM_ITEM;  nm_Label:'Paste';     nm_CommKey:'V';   nm_Flags:0; 
54
 
nm_MutualExclude:0; nm_UserData:NIL),
55
 
    (nm_Type: NM_ITEM;  nm_Label:nil;         nm_CommKey: NIL;  nm_Flags:0; 
56
 
nm_MutualExclude:0; nm_UserData:NIL),
57
 
 
58
 
    (nm_Type: NM_ITEM;  nm_Label:'Undo';      nm_CommKey:'Z';   nm_Flags:0; 
59
 
nm_MutualExclude:0; nm_UserData:NIL),
60
 
 
61
 
    (nm_Type:   NM_END; nm_Label:NIL;         nm_CommKey:NIL;   nm_Flags:0; 
62
 
nm_MutualExclude:0; nm_UserData:NIL));
63
 
 
64
 
var
65
 
   win : pWindow;
66
 
   myVisualInfo : Pointer;
67
 
   menuStrip : pMenu;
68
 
   msg  : pMessage;
69
 
   done : boolean;
70
 
 
71
 
Procedure Die;
72
 
begin
73
 
    if assigned(MenuStrip) then begin
74
 
       ClearMenuStrip(win);
75
 
       FreeMenus(MenuStrip);
76
 
    end;
77
 
    if assigned(myVisualInfo) then FreeVisualInfo(myVisualInfo);
78
 
    if assigned(win) then CloseWindow(win);
79
 
    Halt(0);
80
 
end;
81
 
 
82
 
 
83
 
 
84
 
 
85
 
{*
86
 
** Watch the menus and wait for the user to select the close gadget
87
 
** or quit from the menus.
88
 
*}
89
 
PROCEDURE ProcessIDCMP;
90
 
VAR
91
 
    IMessage    : tIntuiMessage;
92
 
    IPtr    : pIntuiMessage;
93
 
 
94
 
    Procedure ProcessMenu;
95
 
    var
96
 
    MenuNumber  : Word;
97
 
    ItemNumber  : Word;
98
 
    SubItemNumber   : Word;
99
 
 
100
 
    begin
101
 
    if IMessage.Code = MENUNULL then
102
 
        Exit;
103
 
 
104
 
    MenuNumber := MenuNum(IMessage.Code);
105
 
    ItemNumber := ItemNum(IMessage.Code);
106
 
    SubItemNumber := SubNum(IMessage.Code);
107
 
 
108
 
    if (MenuNumber = 0) and (ItemNumber = 5) then done := true;
109
 
    end;
110
 
 
111
 
begin
112
 
    IPtr := pIntuiMessage(Msg);
113
 
    IMessage := IPtr^;
114
 
    ReplyMsg(Msg);
115
 
 
116
 
    case IMessage.IClass of
117
 
      IDCMP_MENUPICK    : ProcessMenu;
118
 
      IDCMP_CLOSEWINDOW : done := True;
119
 
    end;
120
 
end;
121
 
 
122
 
{*
123
 
** Open all of the required libraries and set-up the menus.
124
 
*}
125
 
 
126
 
begin
127
 
 
128
 
    win := OpenWindowTags(NIL, [
129
 
                             WA_Width,  400,
130
 
                             WA_Activate,    ltrue,
131
 
                             WA_Height, 100,
132
 
                             WA_CloseGadget, ltrue,
133
 
                             WA_Title,  'Menu Test Window',
134
 
                             WA_IDCMP,  IDCMP_CLOSEWINDOW or IDCMP_MENUPICK,
135
 
                             TAG_END]);
136
 
    
137
 
    if win = nil then die;
138
 
 
139
 
    myVisualInfo := GetVisualInfoA(win^.WScreen,nil);
140
 
    if myVisualInfo = nil then die;
141
 
 
142
 
    {
143
 
      make the barlabels
144
 
    }
145
 
    mynewmenu[3].nm_Label := PChar(NM_BARLABEL);
146
 
    mynewmenu[7].nm_Label := PChar(NM_BARLABEL);
147
 
    mynewmenu[13].nm_Label := PChar(NM_BARLABEL);
148
 
 
149
 
    if pExecBase(_ExecBase)^.LibNode.Lib_Version >= 39 then begin
150
 
        MenuStrip := CreateMenus(@mynewmenu, [
151
 
                                 GTMN_FrontPen, 1,
152
 
                                 TAG_END]);
153
 
    end else MenuStrip := CreateMenusA(@mynewmenu,NIL);
154
 
 
155
 
    if menuStrip = nil then die;
156
 
 
157
 
    if not LayoutMenusA(menuStrip, myVisualInfo,nil) then die;
158
 
 
159
 
    if not SetMenuStrip(win,menuStrip) then die;
160
 
 
161
 
    repeat
162
 
    Msg := WaitPort(win^.UserPort);
163
 
    Msg := GetMsg(win^.UserPort);
164
 
       ProcessIDCMP;
165
 
    until done;
166
 
    die;
167
 
end.
168
 
 
169
 
{
170
 
  $Log: gtmenu.pas,v $
171
 
  Revision 1.3  2003/01/19 14:57:12  nils
172
 
  * removed mode objfpc
173
 
 
174
 
  Revision 1.2  2002/11/28 19:40:45  nils
175
 
    * update
176
 
 
177
 
}