home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / oasis / samples / sample5.pas < prev    next >
Pascal/Delphi Source File  |  1987-12-12  |  11KB  |  310 lines
  1. PROGRAM Scldemo;
  2. {$R-,S+,I+,D+,T-,F-,V-,B-,N-,L+ }
  3. {$M 16384,0,655360 }
  4.  
  5.  
  6. uses dos,scl;
  7. (*$F+*)   (*Required for background task*)
  8. PROCEDURE Lp_Background_Task;
  9. BEGIN;
  10.   IF (W_ptr > 0) AND (R_ptr > 0) THEN
  11.     BEGIN;                          {both pointers valid}
  12.       IF G_Cont(2) <> Date THEN     {if date has changed}
  13.         W_Cont(2,Date);             {write new one }
  14.       IF G_Cont(3) <> Time(TRUE) THEN {if time has changed}
  15.         W_Cont(3,Time(TRUE));   {write new one with seconds}
  16.     END;
  17. END;
  18. (*$F-*)   (*Reset option again*)
  19.  
  20. FUNCTION Dayname(Dow:INTEGER):String10;  {returns name of day}
  21. BEGIN;
  22.   CASE Dow OF
  23.    0 : Dayname:='Sunday';
  24.    1 : Dayname:='Monday';
  25.    2 : Dayname:='Tuesday';
  26.    3 : Dayname:='Wednesday';
  27.    4 : Dayname:='Thursday';
  28.    5 : Dayname:='Friday';
  29.    6 : Dayname:='Saturday';
  30.   END;
  31. END;
  32.  
  33. PROCEDURE Do_Format(Formatname:String10);
  34. BEGIN;
  35.   Select_Format(Formatname);  {Load the format from disk}
  36.   Display_Format(0,0);        {Display it in the upper left corner}
  37.   REPEAT
  38.     Handle_Format;        {Complete Loop to handle format input}
  39.     IF End_Of_Format THEN
  40.       Blank_Format;       {if finished then clear the screen}
  41.   UNTIL Format_Done; {completely filled in or abort pressed}
  42. END;
  43.  
  44. PROCEDURE Date_Demo;
  45. VAR
  46.   J,
  47.   Diff_J,
  48.   Tj        :REAL;
  49.   Wrkstr    :String80;
  50.   H,Min,S,
  51.   Ty,Tm,Td,Tdow,
  52.   Y,M,D,Dow :word;
  53.  
  54. PROCEDURE Prefill;
  55. BEGIN;
  56.   GetDate(Ty,Tm,Td,Tdow);   {todays date in integer format}
  57.   W_Cont(4,Dayname(Tdow));   {write name of day to field 4}
  58.   Tj:=Julian_Date(Ty,Tm,Td); {convert date to julian format}
  59.   STR(Tj:1:0,Wrkstr);        {convert julian date to string}
  60.   W_Cont(5,Wrkstr);          {and display it in field 5}
  61. END;
  62.  
  63. PROCEDURE Update_User_Date;
  64. BEGIN;
  65.   W_Cont(7,St(D));           {write day to field 7}
  66.   W_Cont(8,St(M));           {write month to field 8}
  67.   W_Cont(9,St(Y));           {write year to field 9}
  68.   W_Cont(10,Date_String(Y,M,D)); {formatted date to field 10}
  69.   J:=Julian_Date(Y,M,D);     {convert to y,m,d to julian date}
  70.   STR(J:1:0,Wrkstr);         {convert julian date to string}
  71.   W_Cont(11,Wrkstr);         {display it in field 11}
  72.   Diff_J:=Abs(Tj - J);       {calculate number of days between}
  73.   STR(Diff_J:1:0,Wrkstr);    {today and  date entered, convert}
  74.   W_Cont(12,Wrkstr);         {to a string and write to field 12}
  75.   W_Cont(13,Dayname(Weekday(Y,M,D))); {name of day to field 13}
  76.   Normal_Date(J+100,Y,M,D);  {caculate entered date + 100 days}
  77.   W_Cont(14,Date_String(Y,M,D)); {convert it to a string and}
  78. END;                         {write it to field 14}
  79.  
  80. PROCEDURE Update_User_Time;
  81. BEGIN;
  82.   W_Cont(16,St(H));      {hours to field 16}
  83.   W_Cont(17,St(Min));    {minutes to field 17}
  84.   W_Cont(18,St(S));      {seconds to field 18}
  85.   W_Cont(19,Time_String(H,Min,S)); {formatted time to field 19}
  86. END;
  87.  
  88.  
  89. PROCEDURE Clear_Fields(Field_From,Field_To:INTEGER);
  90. VAR
  91.   Field:INTEGER;
  92. BEGIN;
  93.   FOR Field:=Field_From TO Field_To DO
  94.     C_Cont(Field);                     {blank this field}
  95. END;
  96.  
  97. PROCEDURE Handle_End_Of_Field;
  98. BEGIN;
  99.   CASE Active_Field OF
  100.     6 : BEGIN;                  {user date entry field}
  101.           Wrkstr:=G_Cont(6);    {read it}
  102.           IF Wrkstr > ' ' THEN  {data was entered}
  103.             BEGIN;
  104.               Check_Date(Wrkstr,Y,M,D); {check and convert}
  105.               IF NOT Glb_Ok THEN        {invalid date entered}
  106.                 BEGIN;
  107.                   Glb_Error:=22;        {error number to SCL}
  108.                   Clear_Fields(7,14);   {blank fields 7-14}
  109.                 END
  110.               ELSE                      {valid entry}
  111.                 Update_User_Date;       {display what we know}
  112.             END
  113.           ELSE                          {blank entered}
  114.             Clear_Fields(7,14);         {clear fields 7-14}
  115.         END;
  116.    15 : BEGIN;                 {user time entry field}
  117.           Wrkstr:=G_Cont(15);  {read it}
  118.           IF Wrkstr > ' ' THEN {time was entered}
  119.             BEGIN;
  120.               Check_Time(Wrkstr,H,Min,S); {check & convert}
  121.               IF NOT Glb_Ok THEN     {invalid time entered}
  122.                 BEGIN;
  123.                   Clear_Fields(16,19); {clear fields 16-19}
  124.                   Glb_Error:=23;       {error number to SCL}
  125.                 END
  126.               ELSE
  127.                 Update_User_Time;      {display user time}
  128.             END
  129.           ELSE                         {blank entered}
  130.             Clear_Fields(16,19);       {clear fields 16-19}
  131.         END;
  132.   END;
  133. END;
  134.  
  135.  
  136.  
  137. BEGIN;
  138.   Select_Format('Datedemo');  {Load the format from disk}
  139.   Prefill;
  140.   Display_Format(0,0);        {Display it in the upper left corner}
  141.   REPEAT
  142.     Handle_Format;
  143.     IF End_Of_Field THEN
  144.       Handle_End_Of_Field     {user interrupt procedures}
  145.     ELSE
  146.     IF End_Of_Format THEN
  147.       Blank_Format;      {if finished then clear the screen}
  148.   UNTIL Format_Done;     {completely filled in or abort pressed}
  149. END;
  150.  
  151.  
  152. PROCEDURE Country_Demo;
  153.  
  154. PROCEDURE Update_Fields;
  155. BEGIN;
  156.   W_Cont(5,St(Country)); {presently used CountryCode to field 5}
  157.   W_Cont(6,Currency);    {currency symbol to field 6}
  158.   W_Cont(7,St(Date_Format)); {date format (0 or 1) to field 7}
  159.   W_Cont(8,Date_Separator);  {..to field 8}
  160.   W_Cont(9,Time_Separator);  {..to field 9}
  161. END;
  162.  
  163. PROCEDURE Handle_End_Of_Field; {user interrupt procedure}
  164. BEGIN;
  165.   IF Active_Field = 4 THEN     {new country code entered}
  166.     BEGIN;
  167.       IF G_Cont(4) > ' ' THEN  {not blank}
  168.         BEGIN;
  169.           Scl_Country:=Nr(G_Cont(4)); {move it to SCL_Country}
  170.           Get_Country;                {get country information}
  171.           IF (Country <> Scl_Country) AND (Scl_Country > 0) THEN
  172.             BEGIN;            {invalid country code was entered}
  173.               Glb_Error:=24;  {error number to SCL}
  174.               Scl_Country:=Nr(G_Cont(5)); {restore old country}
  175.               Get_Country;                {get country info}
  176.             END
  177.           ELSE                {country code was valid}
  178.             Update_Fields;    {display new country info}
  179.         END;
  180.     END;
  181. END;
  182.  
  183. BEGIN;
  184.   Select_Format('Countrydem');  {Load the format from disk}
  185.   Update_Fields;              {prefill fields}
  186.   Display_Format(0,0);  {Display it in the upper left corner}
  187.   REPEAT
  188.     Handle_Format;
  189.     IF End_Of_Field THEN
  190.       Handle_End_Of_Field     {user interrupt procedures}
  191.     ELSE
  192.     IF End_Of_Format THEN
  193.       Blank_Format;       {if finished then clear the screen}
  194.   UNTIL Format_Done;  {completely filled in or abort pressed}
  195. END;
  196.  
  197.  
  198. PROCEDURE Special_Demo;          {showing tricky fields}
  199. PROCEDURE Handle_User_Function;  {key was pressed}
  200. VAR
  201.   Ch:CHAR;
  202.   Wrkstr:String80;
  203. BEGIN;
  204.   CASE Active_Field OF
  205.     5 : BEGIN;                    {multiple states field}
  206.           IF Char_Code = 32 THEN
  207.             BEGIN;
  208.               Wrkstr:=G_Cont(5);
  209.               IF Wrkstr='Red' THEN Wrkstr:='Yellow' ELSE
  210.               IF Wrkstr='Yellow' THEN Wrkstr:='Green' ELSE
  211.               IF Wrkstr='Green' THEN Wrkstr:='Red';
  212.               W_Cont(5,Wrkstr);
  213.               Char_Code:=Code_Noop;
  214.             END;
  215.         END;
  216.     6 : BEGIN;
  217.           Ch:=CHR(Char_Code);
  218.           IF Ch IN ['Y','y','N','n','?'] THEN
  219.             BEGIN;
  220.               IF (Ch = 'Y') OR (Ch = 'y') THEN
  221.                 Wrkstr:='YES'
  222.               ELSE
  223.               IF (Ch = 'N') OR (Ch = 'n') THEN
  224.                 Wrkstr:='NO'
  225.               ELSE
  226.                 Wrkstr:='Dont Know';   {'?' key pressed}
  227.               W_Cont(6,Wrkstr);
  228.               Char_Code:=Code_Noop;
  229.             END;
  230.         END;
  231.     7 : BEGIN;              {display character code}
  232.           IF (Char_Code <> Code_Return) AND (Char_Code > 0) THEN
  233.             BEGIN;                       {not return or NoOp}
  234.               IF Char_Code > 1000 THEN   {a two code key}
  235.                 Wrkstr:='<#27><#'+St(Char_Code-1000)+'>'
  236.               ELSE
  237.                 Wrkstr:='<#'+St(Char_Code)+'>'; {a normal key}
  238.               W_Cont(7,Wrkstr);
  239.               Char_Code:=Code_Noop;
  240.             END;
  241.         END;
  242.     8 : BEGIN;                   {upper case display}
  243.           IF Char_Code < 1000 THEN   {not a <esc> nnn key}
  244.             Char_Code:=ORD(UpCase(CHR(Char_Code)));
  245.         END;
  246.    END;
  247. END;
  248.  
  249. PROCEDURE Handle_End_Of_Field;
  250. BEGIN;
  251.   IF Active_Field = 4 THEN
  252.     BEGIN;
  253.       IF G_Sel(4) THEN        {if selected the display 'Yes'}
  254.         W_Cont(4,'Yes')
  255.       ELSE
  256.         W_Cont(4,'No');       {otherwise display 'No'}
  257.     END;
  258. END;
  259.  
  260.  
  261. BEGIN;
  262.   Select_Format('Special');   {Load the format from disk}
  263.   Display_Format(0,0);    {Display it in the upper left corner}
  264.   REPEAT
  265.     Handle_Format;
  266.     IF User_Function THEN
  267.       Handle_User_Function
  268.     ELSE
  269.     IF End_Of_Field THEN
  270.       Handle_End_Of_Field
  271.     ELSE
  272.     IF End_Of_Format THEN
  273.       Blank_Format;       {if finished then clear the screen}
  274.   UNTIL Format_Done;   {completely filled in or abort pressed}
  275. END;
  276.  
  277.  
  278. PROCEDURE Menu;         {This Procedure handles format 'menu'.}
  279. CONST
  280.   Progend:BOOLEAN=FALSE;   {typed constant, saves a statement}
  281. BEGIN;
  282.   REPEAT
  283.     Select_Format('menu'); {Loads the format from disk}
  284.     Display_Format(X_Max DIV 2,Y_Max DIV 2); {Display in center}
  285.     REPEAT
  286.       Handle_Format;     {Complete Loop to handle format input}
  287.     UNTIL Format_Done;   {completely filled in or abort pressed}
  288.     IF G_Sel(4) THEN Do_Format('var') ELSE {variable field demo}
  289.     IF G_Sel(5) THEN Do_Format('const') ELSE {const field demo}
  290.     IF G_Sel(6) THEN Do_Format('outp') ELSE {output field demo}
  291.     IF G_Sel(7) THEN Do_Format('formatting') ELSE {frmtng demo}
  292.     IF G_Sel(8) THEN Do_Format('layout') ELSE  {formLayout demo}
  293.     IF G_Sel(9) THEN Date_Demo ELSE  {date & time demo}
  294.     IF G_Sel(10) THEN Country_Demo ELSE  {country info demo}
  295.     IF G_Sel(11) THEN Do_Format('helpdemo') ELSE {help demo}
  296.     IF G_Sel(12) THEN Special_Demo ELSE {special fields demo}
  297.     IF G_Sel(13) THEN Progend:=TRUE;
  298.   UNTIL Progend;{...until G_Sel(13) wouldn't work because we}
  299. END;        {would read it from the last demo format rather}
  300.                   {than from 'menu'}
  301.  
  302. BEGIN; {of main}
  303.   Select_Format_File('Sample5');  {initializes SCL and loads the format
  304.                                   {file 'Sample5'}
  305.   lp_background_pointer:=@lp_background_task; (*invoke this procedure as
  306.                                    background task*)
  307.   Menu;                           {load,display and handle the menu}
  308.   Close_Formats;                  {terminate SCL}
  309. END.  {of main}
  310.