← Back to branch summary

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

« back to all changes in this revision

Viewing changes to fpcsrc/packages/extra/amunits/demos/easygadtools.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:
fpcsrc/packages/extra/amunits/demos/easygadtools.pas
 
1
PROGRAM EasyGadtools;
 
2
 
 
3
{
 
4
    This is just a test on how to make a unit EasyGadtools.
 
5
 
 
6
    Feel free to make any changes or improvements on this
 
7
    example. If you make a unit or have a unit to handle
 
8
    gadtools in an easy way let me know.
 
9
    24 Jul 2000.
 
10
 
 
11
    Changed to use systemvartags.
 
12
    25 Nov 2002.
 
13
 
 
14
    nils.sjoholm@mailbox.swipnet.se
 
15
 
 
16
}
 
17
 
 
18
USES Intuition, Exec, Graphics, GadTools, Utility, pastoc,systemvartags;
 
19
 
 
20
CONST
 
21
 
 
22
     strarray : array[0..4] of PChar = ('A cycle',
 
23
                                        'test',
 
24
                                        'for',
 
25
                                        'FPC Pascal',
 
26
                                        nil);
 
27
 
 
28
 
 
29
VAR
 
30
  ps                : pScreen;
 
31
  vi                : Pointer;
 
32
  ng                : tNewGadget;
 
33
  glist,gad         : pGadget;
 
34
  wp                : pWindow;
 
35
  HFont             : word;
 
36
  HGadget           : word;
 
37
  DistGad           : word;
 
38
  HG                : word;
 
39
  attr              : pTextAttr;
 
40
 
 
41
function NewGadget(left,top,width,height : Integer; txt : PChar; txtattr: pTextAttr;
 
42
                   id : word; flags: Longint; visinfo, userdata : Pointer): tNewGadget;
 
43
var
 
44
    ng : tNewGadget;
 
45
begin
 
46
    with ng do begin
 
47
        ng_LeftEdge   := left;
 
48
        ng_TopEdge    := top;
 
49
        ng_Width      := width;
 
50
        ng_Height     := height;
 
51
        ng_GadgetText := txt;
 
52
        ng_TextAttr   := txtattr;
 
53
        ng_GadgetID   := id;
 
54
        ng_Flags      := flags;
 
55
        ng_VisualInfo := visinfo;
 
56
        ng_UserData   := userdata;
 
57
    END;
 
58
    NewGadget := ng;
 
59
end;
 
60
 
 
61
PROCEDURE CleanUp(why : string; rc : BYTE);
 
62
BEGIN
 
63
  IF assigned(wp) THEN CloseWindow(wp);
 
64
  IF assigned(glist) THEN FreeGadgets(glist);
 
65
  IF assigned(vi) THEN FreeVisualInfo(vi);
 
66
  if why <> '' then writeln(why);
 
67
  HALT(rc);
 
68
END;
 
69
 
 
70
{ Clones some datas from default pubscreen for fontsensitive
 
71
  placing of gadgets. }
 
72
PROCEDURE CloneDatas;
 
73
BEGIN
 
74
  ps := LockPubScreen(NIL);
 
75
  IF ps = NIL THEN CleanUp('Can''t get a lock on public screen',20)
 
76
  ELSE
 
77
  BEGIN
 
78
     HFont := ps^.Font^.ta_YSize;
 
79
     attr := ps^.Font;
 
80
     vi := GetVisualInfoA(ps,NIL);
 
81
     UnLockPubScreen(NIL, ps);
 
82
     IF vi = NIL THEN CleanUp('Can''t get VisualInfo', 20);
 
83
  END;
 
84
END;
 
85
 
 
86
function ButtonGadget(id,left,top,width,height:word; txt:pchar): pGadget;
 
87
begin
 
88
   ng := NewGadget(left,top,width,height,txt,attr,id,PLACETEXT_IN,vi,nil);
 
89
   gad := CreateGadgetA(BUTTON_KIND,gad,@ng,nil);
 
90
   ButtonGadget := gad;
 
91
end;
 
92
 
 
93
function ButtonGadget(id,left,top,width,height:word; txt: string): pGadget;
 
94
begin
 
95
   ButtonGadget := ButtonGadget(id,left,top,width,height,pas2c(txt));
 
96
end;
 
97
 
 
98
function CycleGadget(id,left,top,width,height:word; txt:pchar ; thearr : Pointer): pGadget;
 
99
begin
 
100
   ng := NewGadget(left,top,width,height,txt,attr,id,PLACETEXT_LEFT,vi,nil);
 
101
   gad := CreateGadget(CYCLE_KIND,gad,@ng,[
 
102
                                         GTCY_Labels,thearr,
 
103
                                         TAG_END]);
 
104
   CycleGadget := gad;
 
105
end;
 
106
 
 
107
PROCEDURE GenerateWindow;
 
108
BEGIN
 
109
  glist := NIL; gad := CreateContext(addr(glist));
 
110
  IF gad = NIL THEN CleanUp('Can''t create GadList', 20);
 
111
 
 
112
  gad := ButtonGadget(0,10,HG,200,HGadget,'File Requester');
 
113
  HG := HG + DistGad;
 
114
 
 
115
  gad := ButtonGadget(1,10,HG,200,HGadget,'Font Requester');
 
116
  HG := HG + DistGad;
 
117
 
 
118
  gad := ButtonGadget(2,10,HG,200,HGadget,'Screen Requester');
 
119
  HG := HG + DistGad + 3;
 
120
 
 
121
  gad := CycleGadget(3,100,HG,100,HGadget,'Cycle me',@strarray);
 
122
  HG := HG + DistGad+4;
 
123
 
 
124
  gad := ButtonGadget(4,10,HG,96,HGadget,'OK');
 
125
  gad := ButtonGadget(5,115,HG,96,HGadget,'Cancel');
 
126
 
 
127
  HG := HG + 5;
 
128
 
 
129
  if gad = nil then CleanUp('Can''t create gadgets',20);
 
130
 
 
131
  wp := OpenWindowTags(NIL,[
 
132
                WA_Gadgets, glist,
 
133
                WA_Title, 'Test of EasyGadtools',
 
134
                WA_Left,100,
 
135
                WA_Top,100,
 
136
                WA_Flags, WFLG_SMART_REFRESH OR WFLG_NOCAREREFRESH OR
 
137
                                WFLG_DEPTHGADGET OR WFLG_DRAGBAR OR WFLG_CLOSEGADGET OR
 
138
                                WFLG_ACTIVATE,
 
139
                WA_Idcmp, IDCMP_GADGETUP OR IDCMP_CLOSEWINDOW,
 
140
                WA_InnerWidth, 215,
 
141
                WA_InnerHeight, HG,
 
142
                TAG_DONE]);
 
143
 
 
144
  IF wp = NIL THEN CleanUp('Can''t open window', 20);
 
145
END;
 
146
 
 
147
PROCEDURE MainWait;
 
148
VAR
 
149
  msg : pIntuiMessage;
 
150
  iclass : LONG;
 
151
  ende : BOOLEAN;
 
152
BEGIN
 
153
  ende := FALSE;
 
154
  REPEAT
 
155
    msg := pIntuiMessage(WaitPort(wp^.UserPort));
 
156
     msg := GT_GetIMsg(wp^.UserPort);
 
157
     WHILE msg <> NIL DO
 
158
     BEGIN
 
159
        iclass := msg^.IClass;
 
160
        GT_ReplyIMsg(msg);
 
161
        CASE iclass OF
 
162
          IDCMP_CLOSEWINDOW : ende := TRUE;
 
163
          IDCMP_GADGETUP : writeln('You clicked on a gadget');
 
164
        ELSE END;
 
165
       msg := GT_GetIMsg(wp^.UserPort);
 
166
     END;
 
167
  UNTIL ende;
 
168
END;
 
169
 
 
170
BEGIN
 
171
  CloneDatas;
 
172
  HGadget := HFont +6;
 
173
  DistGad := HGadget +4;
 
174
  HG := HFont + 10;
 
175
  GenerateWindow;
 
176
  MainWait;
 
177
  CleanUp('',0);
 
178
END.