home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / timer / tptimer / dates2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-14  |  15.1 KB  |  405 lines
  1. UNIT Dates2;    {Version 1.02 updated 14th November 1988}
  2.  
  3.  
  4. {***************************************************************************
  5.  *                                                                         *
  6.  *                     Copyright 1988 Trevor J Carlsen                     *
  7.  *                   Rovert Software Consulting Services                   *
  8.  *                                PO Box 568                               *
  9.  *                   Port Hedland Western Australia 6721                   *
  10.  *                                                                         *
  11.  *                                                                         *
  12.  *                                                                         *
  13.  *    All these routines are based on the  global  type  Date  which  is   *
  14.  *    globally declared as a longint. As all calculations are in seconds   *
  15.  *    the valid range of date/time is  restricted to 00:00:00 01-01-1981   *
  16.  *    until 23:59:59 31-12-2048.                                           *
  17.  *                                                                         *
  18.  *    This unit is functionally identical to DATES.PAS but has a function  *
  19.  *    Zstr added to replace the form function and thus make it independent *
  20.  *    of the Turbo Professional package.                                   *
  21.  *                                                                         *
  22.  ***************************************************************************}
  23.  
  24. interface
  25.  
  26. TYPE
  27.   Date = longint;
  28.   DaysOfWeek = array[0..6] of string[9];
  29.   months = array[1..12] of string[9];
  30.  
  31. CONST
  32.   WeekDay : DaysOfWeek = ('Sunday','Monday','Tuesday','Wednesday',
  33.                           'Thursday','Friday','Saturday');
  34.   Amonth : months = ('January','February','March','April','May','June',
  35.                   'July','August','September','October','November','December');
  36. {-----------------------------------------------------------------------------}
  37.  
  38. FUNCTION Zstr(numb : byte): string;
  39. {-Adds a leading zero to a single digit number
  40.  
  41. ------------------------------------------------------------------------------}
  42.  
  43. FUNCTION DayOfTheWeek(pd : date): byte;
  44. { Returns the day of the week for any date  Sunday = 0 .. Sat = 6
  45.  
  46. ------------------------------------------------------------------------------}
  47.  
  48. PROCEDURE PackDateAndTime(VAR pd : date; yr,mth,d,hr,m,s : word);
  49. { This procedure packs the Date and time into a 4 byte long integer using
  50.   a different method to that used by DOS and the TP4 compiler. Each date
  51.   and time are recorded as the number of elapsed seconds since 01-01-1981.
  52.   The valid range is from 00:00:00 01-01-1988 until 23:59:59 31-12-2048.
  53.   This method enables elapsed times and times between 2 times to be more
  54.   easily calculated. It is also fully "sortable".
  55.  
  56. ------------------------------------------------------------------------------}
  57.  
  58. PROCEDURE UnPackDateAndTime(VAR yr,mth,d,hr,m,s : word; pd : date);
  59. { Unpacks a packed date from a long integer created by PackDateAndTime into
  60.   its component parts.
  61.  
  62. ------------------------------------------------------------------------------}
  63.  
  64. PROCEDURE ParseDateTime(st : string; fmt : byte;
  65.                         VAR yr,mth,d,hr,m,s : word; VAR code : byte);
  66. { Breaks a string into its component parts for use by PackDateAndTime and
  67.   ValidDate.  I have included 4 formats and used a format flag.
  68.         fmt = 0  dd-mm-yyyy hh:mm:ss
  69.         fmt = 1  mm-dd-yyyy hh:mm:ss (must keep our American friends happy!)
  70.         fmt = 2  ddmmyyyy hhmmss  (no separators makes for easier data entry)
  71.         fmt = 3  mmddyyyy hhmmss
  72.   code is used to pass an error back to the calling routine. Any error which
  73.   prevents the proper parsing of a string will set this variable to a non
  74.   zero value.
  75.  
  76. ------------------------------------------------------------------------------}
  77.  
  78. FUNCTION ValidDate(yr,mth,d,hr,m,s : word; VAR errorcode : byte): boolean;
  79. { Validates the date and time data to ensure no out of range errors can
  80.   occur and returns an error code to the calling procedure. A errorcode of
  81.   zero is returned if no invalid parameter is detected. Errorcodes are as
  82.   follows:
  83.         Year out of range (<1981 or > 2048)  bit 0 of errorcode is set.
  84.         Month < 1 or > 12                    bit 1 of errorcode is set.
  85.         Day < 1 or > 31                      bit 2 of errorcode is set.
  86.         Day out of range for month           bit 2 of errorcode is set.
  87.         Hour < 0 or > 23                     bit 3 of errorcode is set.
  88.         Minute < 0 or > 59                   bit 4 of errorcode is set.
  89.         Second < 0 or > 59                   bit 5 of errorcode is set.
  90.         Error from ParseDateTime             bit 7 of errorcode is set.
  91.   Using the method indicated allows the calling routine to detect what
  92.   type of error caused ValidDate to return false. It also means that a
  93.   combination of errors can be detected.
  94.  
  95. ------------------------------------------------------------------------------}
  96.  
  97. FUNCTION UnPack2Str(pd : date; fmt : byte): string;
  98.  
  99. { Unpacks a time and date from a long integer into a string of a selected
  100.   format
  101.      for the time of 11:59:59PM on the 31st December 1987
  102.      fmt = 0   returns  23:59:59 31-12-1987
  103.            1            23:59:59 12-31-1987
  104.            2            11:59pm 31-12-1987
  105.            3            11:59pm 12-12-1987
  106.            4            23:59:59 December 31, 1987
  107.            5            11:59pm December 31, 1987
  108.            6            23:59, Saturday, December 31, 1987
  109.            7            11:59pm, Saturday, December 31, 1987
  110.            8            31121987 235959
  111.           10            11:59:59pm, Saturday, December 31, 1987
  112.           11            23:59:59
  113.  
  114. ------------------------------------------------------------------------------}
  115.  
  116. FUNCTION TimeStr(pd :date): string;
  117. { returns the current time as a string - equivalent to using UnPack2Str option
  118.   11.
  119.  
  120. ------------------------------------------------------------------------------}
  121.  
  122. FUNCTION NumbOfDaysInMth(y,m : word): byte;
  123. { returns the number of days in any month
  124.  
  125. ------------------------------------------------------------------------------}
  126.  
  127. PROCEDURE AddMonth(VAR pd : date; incr,day : byte);
  128. { Adds incr calendar months to a date.
  129.   If the date being incremented has no exact equivalent in the target month
  130.   then the last day of that month is substituted.
  131.     ie.  Incrementing the 31 Jan 1988 would result in 29 Feb 1988
  132.   Conversely, if incrementing a short month and it is desired for a day other
  133.   than the direct equivalent, set day to the desired day.
  134.     ie.  Incrementing 29 Feb 1988 and the last day of march is required set
  135.          day to 31.
  136.   Setting day to 31 will ALWAYS result in the incremented date being the last
  137.   day of the month.
  138.   Setting day to 30 will ALWAYS result in the incremented date being the 30th
  139.   day of the month except in February when it will be either the 29th or 28th.
  140.   As from version 1.02 this function will not permit pd to be outside the
  141.   range permitted.
  142.  
  143. ------------------------------------------------------------------------------}
  144.  
  145. PROCEDURE DecMonth(VAR pd : date; decr,day : byte);
  146. { Decrements a date by decr calendar months
  147.   The same comments and rules apply as for AddMonth
  148.  
  149. ------------------------------------------------------------------------------}
  150.  
  151. PROCEDURE AddYear(VAR pd : date; incr,day : byte);
  152. { Adds one year to a date
  153.   The same comments and rules apply as for AddMonth where February is the
  154.   month involved.
  155.  
  156. ------------------------------------------------------------------------------}
  157.  
  158.  
  159.  
  160.  
  161.  
  162. {=============================================================================}
  163.  
  164. implementation
  165.  
  166.  CONST
  167.   TDays : array[0..1,0..12] of word =
  168.          ((0,31,59,90,120,151,181,212,243,273,304,334,365),
  169.          (0,31,60,91,121,152,182,213,244,274,305,335,366));
  170.  
  171. FUNCTION Zstr(numb : byte): string;
  172.   {-simple function to add a leading zero to a single digit number}
  173.   VAR temp : string[2];
  174.   begin
  175.     Str(numb, temp);
  176.     if length(temp) = 1 then temp := '0'+ temp;
  177.     Zstr := temp;
  178.   end;  {Zstr}
  179.  
  180. FUNCTION DayOfTheWeek(pd : date): byte;
  181.   begin
  182.     DayOfTheWeek := (((pd div 86400) mod 7)+4) mod 7;
  183.   end;
  184.  
  185. PROCEDURE PackDateAndTime(VAR pd : date; yr,mth,d,hr,m,s : word);
  186.   VAR
  187.     total, temp : date;
  188.     lyr : byte;
  189.   begin
  190.     lyr := ord(yr mod 4 = 0);
  191.     dec(yr,1981);
  192.     total := s + (m * 60) + (date(hr) * 3600);
  193.     temp := date(yr * word(365) + (yr div 4));
  194.     inc(temp,TDays[lyr][mth-1]);
  195.     inc(temp,d-1);
  196.     pd := total + (temp * 86400);
  197.   end;  {PackTimeAndDate}
  198.  
  199. PROCEDURE UnPackDateAndTime(VAR yr,mth,d,hr,m,s : word; pd : date);
  200.   VAR
  201.     julian : word;
  202.     temp : date;
  203.     lyr : byte;
  204.   begin
  205.     d := word(pd div 86400 + 1);
  206.     temp := pd mod 86400;
  207.     hr := word(temp div 3600);
  208.     temp := temp mod 3600;
  209.     m := word(temp div 60);
  210.     s := word(temp mod 60);
  211.     yr := (date(d) * 4) div 1461;
  212.     julian := d - (yr * 365 + (yr div 4));
  213.     inc(julian,366 * ord(julian = 0));      { make sure that last day of a }
  214.     inc(yr,1981 - ord(julian = 366));       { leap year is shown correctly }
  215.     lyr := ord(yr mod 4 = 0);
  216.     mth := 0;
  217.     while julian > TDays[lyr][mth] do
  218.       inc(mth);
  219.     d := julian - TDays[lyr][mth-1];
  220.   end;
  221.  
  222. PROCEDURE ParseDateTime(st : string; fmt : byte;
  223.                         VAR yr,mth,d,hr,m,s : word;
  224.                         VAR code : byte);
  225.   CONST
  226.       offset : array[0..3,1..6] of byte = ((1,4,7,12,15,18),
  227.                                            (4,1,7,12,15,18),
  228.                                            (1,3,5,10,12,14),
  229.                                            (3,1,5,10,12,14));
  230.   VAR result : integer;
  231.   begin
  232.     code := 0;
  233.     val(copy(st,offset[fmt][1],2),d,result);
  234.     inc(code,result);
  235.     val(copy(st,offset[fmt][2],2),mth,result);
  236.     inc(code,result);
  237.     val(copy(st,offset[fmt][3],4),yr,result);
  238.     inc(code,result);
  239.     val(copy(st,offset[fmt][4],2),hr,result);
  240.     inc(code,result);
  241.     val(copy(st,offset[fmt][5],2),m,result);
  242.     inc(code,result);
  243.     val(copy(st,offset[fmt][6],2),s,result);
  244.     inc(code,result);
  245.   end;
  246.  
  247. FUNCTION ValidDate(yr,mth,d,hr,m,s : word; VAR errorcode : byte): boolean;
  248.   VAR code : byte;
  249.   begin
  250.     code := errorcode;
  251.     errorcode := ord(code <> 0) * 128; {set high bit if error returned from
  252.                                         parsedatetime routine}
  253.     if (yr < 1981) or (yr > 2048) then errorcode := (errorcode or 1);
  254.     if (d < 1) or (d > 31) then errorcode := (errorcode or 2);
  255.     if (mth < 1) or (mth > 12) then errorcode := (errorcode or 4);
  256.     case mth of
  257.       4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
  258.              2: if d > (28 + ord((yr mod 4) = 0)) then
  259.                   errorcode := (errorcode or 2);
  260.       end; {case}
  261.     if (hr < 0) or (hr > 23) then errorcode := (errorcode or 8);
  262.     if (m < 0)  or (m  > 59) then errorcode := (errorcode or 16);
  263.     if (s < 0)  or (s  > 59) then errorcode := (errorcode or 32);
  264.     ValidDate := (errorcode = 0);
  265.   end;
  266.  
  267. FUNCTION UnPack2Str(pd : date; fmt : byte): string;
  268.   VAR tempstr : string;
  269.       ampm : string[10];
  270.       y : string[4];
  271.       hr,m,s,yr,mth,d: word;
  272.   begin
  273.     tempstr := '';
  274.     str(yr:4,y);
  275.     UnPackDateAndTime(yr,mth,d,hr,m,s,pd);
  276.     case fmt of
  277.       2,3,5,7,10:begin
  278.                    if (hr = 0) and (m = 0) and (s = 0) then begin
  279.                       ampm := ' midnight';
  280.                       hr := 12;
  281.                       end
  282.                     else if hr < 12 then ampm := 'am'
  283.                     else if (hr = 12) and (m = 0) and (s = 0) then ampm := ' noon'
  284.                     else ampm := 'pm';
  285.                     if hr > 12 then dec(hr,12);
  286.                   end;
  287.     end; {case}
  288.     case fmt of
  289.         11: tempstr := Zstr(hr)+':'+Zstr(m)+':'+Zstr(s);
  290.        0,1: begin
  291.               tempstr := Zstr(hr)+':'+Zstr(m)+':'+Zstr(s)+' ';
  292.               if fmt = 0 then
  293.                 tempstr := tempstr +
  294.                          Zstr(d)+'-'+Zstr(mth)+'-'+ y
  295.               else
  296.                 tempstr := tempstr +
  297.                          Zstr(mth)+'-'+Zstr(d)+'-'+ y
  298.            end;
  299.   2..7,10: begin
  300.               if fmt <> 4 then begin
  301.                 tempstr := ampm;
  302.                 if fmt > 5 then tempstr := tempstr + ', '+
  303.                   WeekDay[DayOfTheWeek(pd)]+', ';
  304.               end;
  305.               if fmt = 10 then
  306.                 tempstr := Zstr(hr)+':'+Zstr(m)+':'+Zstr(s) + tempstr
  307.               else tempstr := Zstr(hr)+':'+Zstr(m) + tempstr;
  308.               case fmt of
  309.                 2: tempstr := tempstr + Zstr(d)+'-'+Zstr(mth)+'-'+ y;
  310.                 3: tempstr := tempstr + Zstr(mth)+'-'+Zstr(d)+'-'+ y;
  311.                 4: tempstr := tempstr + Zstr(s) + ' ';
  312.           4,5,6,7,10: tempstr := tempstr + Amonth[mth]+' '+ Zstr(d) + ', '+ y;
  313.               end; {case}
  314.             end;
  315.         8: tempstr := Zstr(d)+Zstr(mth)+y+' '+
  316.                       Zstr(hr)+Zstr(m)+Zstr(s);
  317.     end; {case}
  318.     UnPack2Str := tempstr;
  319.   end; {UnPack2Str}
  320.  
  321. FUNCTION TimeStr(pd :date): string;
  322.   CONST mask = '@#';
  323.   VAR hr,m,s,yr,mth,d: word;
  324.   begin
  325.     UnPackDateAndTime(yr,mth,d,hr,m,s,pd);
  326.     TimeStr := Zstr(hr)+':'+Zstr(m)+':'+Zstr(s);
  327.   end;  {TimeStr}
  328.  
  329.  
  330. FUNCTION NumbOfDaysInMth(y,m : word): byte;
  331.   begin
  332.     case m of
  333.       1,3,5,7,8,10,12: NumbOfDaysInMth := 31;
  334.       4,6,9,11       : NumbOfDaysInMth := 30;
  335.       2              : NumbOfDaysInMth := 28 + ord((y mod 4) = 0);
  336.     end;
  337.   end;
  338.  
  339.  
  340. PROCEDURE AddMonth(VAR pd : date; incr,day : byte);
  341.   VAR yr,mth,d,hr,m,s : word;
  342.       pdate : date;
  343.   begin
  344.     pdate := pd;
  345.     UnPackDateAndTime(yr,mth,d,hr,m,s,pdate);
  346.     inc(yr,incr div 12);
  347.     incr := incr mod 12;
  348.     inc(mth,incr);
  349.     if mth > 12 then begin
  350.       inc(yr,1);
  351.       dec(mth,12);
  352.       end;
  353.     if yr > 2048 then begin
  354.       yr := 2048;
  355.       mth := 12;
  356.       end;
  357.     if day <> 0 then d := day;
  358.     if d > NumbOfDaysInMth(yr,mth) then
  359.       d := NumbOfDaysInMth(yr,mth);
  360.     PackDateAndTime(pdate,yr,mth,d,hr,m,s);
  361.     pd := pdate;
  362.   end;
  363.  
  364. PROCEDURE DecMonth(VAR pd : date; decr,day : byte);
  365.   VAR yr,mth,d,hr,m,s : word;
  366.       pdate : date;
  367.       temp : integer;
  368.   begin
  369.     pdate := pd;
  370.     UnPackDateAndTime(yr,mth,d,hr,m,s,pdate);
  371.     dec(yr,decr div 12);
  372.     decr := decr mod 12;
  373.     temp := integer(mth);
  374.     dec(temp,decr);
  375.     if temp < 1 then begin
  376.       dec(yr,1);
  377.       inc(temp,12);
  378.       end;
  379.     mth := word(temp);
  380.     if yr < 1981 then begin
  381.       yr := 1981;
  382.       mth := 1;
  383.       end;
  384.     if day <> 0 then d := day;
  385.     if d > NumbOfDaysInMth(yr,mth) then
  386.       d := NumbOfDaysInMth(yr,mth);
  387.     PackDateAndTime(pdate,yr,mth,d,hr,m,s);
  388.     pd := pdate;
  389.   end;
  390.  
  391. PROCEDURE AddYear(VAR pd : date; incr,day : byte);
  392.   VAR yr,mth,d,hr,m,s : word;
  393.   begin
  394.     UnPackDateAndTime(yr,mth,d,hr,m,s,pd);
  395.     inc(yr,incr);
  396.     if day <> 0 then d := day;
  397.     if d > NumbOfDaysInMth(yr,mth) then
  398.       d := NumbOfDaysInMth(yr,mth);
  399.     if yr > 2048 then yr := 2048;
  400.     PackDateAndTime(pd,yr,mth,d,hr,m,s);
  401.   end;
  402.  
  403.  
  404. end.
  405.