1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
program ProgIndex;
(*
* OpenTriton -- A free release of the triton.library source code
* Copyright (C) 1993-1998 Stefan Zeiger
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*
* progind.c - Progress indicator demo
*
*)
{
A demo in FPC Pascal using triton.library
Updated for fpc 1.0.7
11 Jan 2003.
nils.sjoholm@mailbox.swipnet.se
}
uses triton, tritonmacros, amigados, utility;
const
ID_MAIN_GADGET_STOP = 1;
ID_MAIN_PROGIND = 2;
var
Triton_App : pTR_App;
procedure do_main;
var
close_me : boolean;
trmsg : pTR_Message;
project : pTR_Project;
i : Longint;
begin
close_me := false;
i := 0;
ProjectStart;
WindowID(1);
WindowTitle('Progress Indicator Demo');
WindowPosition(TRWP_CENTERDISPLAY);
WindowFlags(TRWF_NOCLOSEGADGET OR TRWF_NOESCCLOSE);
VertGroupA;
Space; CenteredText('Working...');
Space; HorizGroupA;
Space; Progress(100,0,ID_MAIN_PROGIND); (* A per cent progress indicator *)
Space; EndGroup;
SpaceS;HorizGroupA;
Space; HorizGroupSA; TextN('000%'); Space; TextN('050%'); Space; TextN('100%'); EndGroup;
Space; EndGroup;
Space; HorizGroupSA;
Space; ButtonE('_Stop',ID_MAIN_GADGET_STOP);
Space; EndGroup;
Space; EndGroup;
EndProject;
project := TR_OpenProject(Triton_App,@tritontags);
IF Project <> NIL THEN BEGIN
WHILE NOT close_me DO BEGIN
TR_SetAttribute(project,ID_MAIN_PROGIND,TRAT_Value,i);
DOSDelay(10);
REPEAT
trmsg := TR_GetMsg(Triton_App);
IF trmsg <> NIL THEN BEGIN
IF (trmsg^.trm_Project = Project) THEN BEGIN
CASE trmsg^.trm_Class OF
TRMS_ERROR: WriteLN(TR_GetErrorString(trmsg^.trm_Data));
TRMS_ACTION :
BEGIN
CASE trmsg^.trm_ID OF
ID_MAIN_GADGET_STOP : close_me := True;
END;
END;
ELSE
END;
END;
TR_ReplyMsg(trmsg);
END;
UNTIL close_me OR (trmsg = NIL);
inc(i);
if i = 101 then close_me := true;
END;
TR_CloseProject(project);
END ELSE WriteLN(TR_GetErrorString(TR_GetLastError(Triton_App)));
end;
(* /////////////////////////////////////////////////////////////////////////////////////////////////////// *)
(* ////////////////////////////////////////////////////////////////////////////////////// Main function // *)
(* /////////////////////////////////////////////////////////////////////////////////////////////////////// *)
begin
Triton_App := TR_CreateAppTags([
TRCA_Name,'trProgIndDemo',
TRCA_Version,'1.0',
TAG_END]);
if Triton_App <> nil then begin
do_main;
TR_DeleteApp(Triton_App);
end
else writeln('Can''t create application');
end.
|
