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