home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / PARADIS1 / TCDATE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-04-02  |  10KB  |  289 lines
  1. (3279)  Mon 30 Mar 92 22:34
  2. By: Mike Copeland
  3. To: Benjamin Lin
  4. Re: HELP on date
  5. St:
  6. ---------------------------------------------------------------------------
  7. @EID:af49 187eb453
  8. @MSGID: 1:114/18.10 29d7fb6a
  9. @REPLY: 3:640/935.2 29d4fa88
  10.  BL>HELP! I need a routine to allow my to calculate a date from from another
  11.  BL>date.
  12.  BL>For example, I want to know what is the date of the day which is 45 days
  13.  BL>after
  14.  BL>28 March 1992, how do I do it?
  15.  
  16.    I'm including an enhanced version of TeeCee's Date Unit, which should give
  17. you the parts you need: convert the date to Ordinal, add 45, and convert it
  18. back:
  19.  
  20. UNIT TCDate;                          { Date Routines  920229 }
  21.  
  22.   { Author: Trevor J Carlsen  Released into the public domain }
  23.   {   augmented by Mike Copeland   }
  24.  
  25. interface
  26.  
  27. uses dos;
  28.  
  29. type
  30.   Date       = word;
  31. const
  32.   WeekDays   : array[0..6] of string[9] =
  33.                ('Sunday','Monday','Tuesday','Wednesday','Thursday',
  34.                 'Friday','Saturday');
  35.   months     : array[1..12] of string[9] =
  36.  
  37. ('January','February','March','April','May','June','July',
  38.                 'August','September','October','November','December');
  39.  
  40. function DayOfTheWeek(pd : date): byte;
  41.  { Returns the day of the week for any date  Sunday = 0 .. Sat = 6    }
  42.  { pd = a packed date as returned by the function PackedDate          }
  43.  { eg...  writeln('Today is ',WeekDays[DayOfTheWeek(Today))];         }
  44.  
  45. function PackedDate(yr,mth,d: word): date;
  46.  { Packs a date into a word which represents the number of days since }
  47.  { Dec 31,1899   01-01-1900 = 1                                       }
  48.  
  49. procedure UnPackDate(VAR yr,mth,d: word; pd : date);
  50.  { Unpacks a word returned by the function PackedDate into its        }
  51.  { respective parts of year, month and day                            }
  52.  
  53. function DateStr(pd: date; format: byte): string;
  54.  { Unpacks a word returned by the function PackedDate into its        }
  55.  { respective parts of year, month and day and then returns a string  }
  56.  { formatted according to the specifications required.                }
  57.  { If the format is > 9 then the day of the week is prefixed to the   }
  58.  { returned string.                                                   }
  59.  { Formats supported are:                                             }
  60.  {     0:  dd/mm/yy                                                   }
  61.  {     1:  mm/dd/yy                                                   }
  62.  {     2:  dd/mm/yyyy                                                 }
  63.  {     3:  mm/dd/yyyy                                                 }
  64.  {     4:  [d]d xxx yyyy   (xxx is alpha month of 3 chars)            }
  65.  {     5:  xxx [d]d, yyyy                                             }
  66.  {     6:  [d]d FullAlphaMth yyyy                                     }
  67.  {     7:  FullAlphaMth [d]d, yyyy                                    }
  68.  {     8:  [d]d-xxx-yy                                                }
  69.  {     9:  xxx [d]d, 'yy                                              }
  70.  
  71.  
  72. function ValidDate(yr,mth,d : word; VAR errorcode : byte): boolean;
  73.  { Validates the date and time data to ensure no out of range errors  }
  74.  { can occur and returns an error code to the calling procedure. A    }
  75.  { errorcode of zero is returned if no invalid parameter is detected. }
  76.  { Errorcodes are as follows:                                         }
  77.  
  78.  {   Year out of range (< 1900 or > 2078) bit 0 of errorcode is set.  }
  79.  {   Month < 1 or > 12                    bit 1 of errorcode is set.  }
  80.  {   Day < 1 or > 31                      bit 2 of errorcode is set.  }
  81.  {   Day out of range for month           bit 2 of errorcode is set.  }
  82.  
  83. procedure ParseDateString(var dstr; var y,m,d : word; format : byte);
  84.  { Parses a date string in several formats into its component parts   }
  85.  { It is the programmer's responsibility to ensure that the string    }
  86.  { being parsed is a valid date string in the format expected.        }
  87.  { If the year string is of 2 characters then the year returned will  }
  88.  { have 1900 added if > 50 and 2000 added if under 51.                }
  89.  { Formats supported are:                                             }
  90.  {     0:  dd/mm/yy[yy]                                               }
  91.  {     1:  mm/dd/yy[yy]                                               }
  92.  
  93.  
  94. function NumbOfDaysInMth(y,m : word): byte;
  95.  { returns the number of days in any month                            }
  96.  
  97. function Today : date;
  98.  { returns the number of days since 31-12-1899                        }
  99.  
  100. function OrdDate (Y,M,D : Word):LongInt; { returns Ordinal Date yyddd }
  101. function DateOrd (S : string) : string;    { returns Date as 'yymmdd' }
  102.  
  103. implementation
  104.  
  105.  const
  106.   TDays : array[Boolean,0..12] of word =
  107.          ((0,31,59,90,120,151,181,212,243,273,304,334,365),
  108.          (0,31,60,91,121,152,182,213,244,274,305,335,366));
  109.  
  110. function OrdDate (Y,M,D : Word): LongInt;     { returns Ordinal Date as yyddd }
  111. var LYR  : boolean;
  112.     TEMP : LongInt;
  113. begin
  114.   LYR := (Y mod 4 = 0) and (Y <> 1900);
  115.   Dec (Y,1900);
  116.   TEMP := LongInt(Y) * 1000;
  117.   Inc (TEMP,TDays[LYR][M-1]);    { compute # days through last month }
  118.   Inc (TEMP,D);                                  { # days this month }
  119.   OrdDate := TEMP
  120. end;  { OrdDate }
  121.  
  122. function DateOrd (S : string) : string;    { returns Date as 'yymmdd' }
  123. var LYR   : boolean;
  124.     Y,M,D : Word;
  125.     TEMP  : LongInt;
  126.     N     : integer;
  127.     STOP  : boolean;
  128.     SW,ST : string[6];
  129. begin
  130.   Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),TEMP,N);
  131.   Inc (Y,1900); LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900);
  132.   N := 0; STOP := false;
  133.   while not STOP and (TDays[LYR][N] < TEMP) do
  134.     Inc (N);
  135.   M := N;                                                     { month }
  136.   D := TEMP-TDays[LYR][M-1];        { subtract # days thru this month }
  137.   Str(Y:2,SW); Str(M:2,ST);
  138.   if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  139.   Str(D:2,ST);
  140.   if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
  141.   DateOrd := SW
  142. end;  { DateOrd }
  143.  
  144. function DayOfTheWeek(pd : date): byte;
  145.   begin
  146.     DayOfTheWeek := pd mod 7;
  147.   end;
  148.  
  149. function PackedDate(yr,mth,d : word): date;
  150.   { valid for all years 1900 to 2078                                  }
  151.   var
  152.     temp  : word;
  153.     lyr   : boolean;
  154.   begin
  155.     lyr   := (yr mod 4 = 0) and (yr <> 1900);
  156.     dec(yr,1900);
  157.     temp  := yr * word(365) + (yr div 4) - ord(lyr);
  158.     inc(temp,TDays[lyr][mth-1]);
  159.     inc(temp,d);
  160.     PackedDate := temp;
  161.   end;  { PackedDate }
  162.  
  163. procedure UnPackDate(var yr,mth,d: word; pd : date);
  164.   { valid for all years 1900 to 2078                                  }
  165.   var
  166.     julian : word;
  167.     lyr    : boolean;
  168.   begin
  169.     d      := pd;
  170.     yr     := (longint(d) * 4) div 1461;
  171.     julian := d - (yr * 365 + (yr div 4));
  172.     inc(yr,1900);
  173.     lyr    := (yr mod 4 = 0) and (yr <> 1900);
  174.     inc(julian,ord(lyr));
  175.     mth    := 0;
  176.     while julian > TDays[lyr][mth] do
  177.       inc(mth);
  178.     d      := julian - TDays[lyr][mth-1];
  179.   end; { UnPackDate }
  180.  
  181. function DateStr(pd: date; format: byte): string;
  182.  
  183.   var
  184.     y,m,d    : word;
  185.     YrStr    : string[5];
  186.     MthStr   : string[11];
  187.     DayStr   : string[8];
  188.     TempStr  : string[5];
  189.   begin
  190.     UnpackDate(y,m,d,pd);
  191.     str(y,YrStr);
  192.     str(m,MthStr);
  193.     str(d,DayStr);
  194.     TempStr := '';
  195.     if format > 9 then
  196.       TempStr := copy(WeekDays[DayOfTheWeek(pd)],1,3) + ', ';
  197.     if (format mod 10) < 4 then begin
  198.       if m < 10 then
  199.         MthStr := '0'+MthStr;
  200.       if d < 10 then
  201.         DayStr := '0'+DayStr;
  202.     end;
  203.     case format mod 10 of  { force format to a valid value }
  204.       0: DateStr := TempStr+DayStr+'/'+MthStr+'/'+copy(YrStr,3,2);
  205.       1: DateStr := TempStr+MthStr+'/'+DayStr+'/'+copy(YrStr,3,2);
  206.       2: DateStr := TempStr+DayStr+'/'+MthStr+'/'+YrStr;
  207.       3: DateStr := TempStr+MthStr+'/'+DayStr+'/'+YrStr;
  208.       4: DateStr := TempStr+DayStr+' '+copy(months[m],1,3)+' '+YrStr;
  209.       5: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+' '+YrStr;
  210.       6: DateStr := TempStr+DayStr+' '+months[m]+' '+YrStr;
  211.       7: DateStr := TempStr+months[m]+' '+DayStr+' '+YrStr;
  212.       8: DateStr :=
  213. TempStr+DayStr+'-'+copy(months[m],1,3)+'-'+copy(YrStr,3,2);
  214.       9: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+','''+
  215.                      copy(YrStr,3,2);
  216.     end;  { case }
  217.   end;  { DateStr }
  218.  
  219. function ValidDate(yr,mth,d : word; var errorcode : byte): boolean;
  220.   begin
  221.     errorcode := 0;
  222.     if (yr < 1900) or (yr > 2078) then
  223.       errorcode := (errorcode or 1);
  224.     if (d < 1) or (d > 31) then
  225.       errorcode := (errorcode or 2);
  226.     if (mth < 1) or (mth > 12) then
  227.       errorcode := (errorcode or 4);
  228.     case mth of
  229.       4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
  230.              2: if d > (28 + ord((yr mod 4) = 0)) then
  231.                   errorcode := (errorcode or 2);
  232.       end; {case }
  233.     ValidDate := (errorcode = 0);
  234.     if errorcode <> 0 then write(#7);
  235.   end;
  236.  
  237. procedure ParseDateString(var dstr; var y,m,d : word; format : byte);
  238.   var
  239.     left,middle       : word;
  240.     errcode           : integer;
  241.     st                : string absolute dstr;
  242.   begin
  243.     val(copy(st,1,2),left,errcode);
  244.     val(copy(st,4,2),middle,errcode);
  245.     val(copy(st,7,4),y,errcode);
  246.     if y < 1900 then
  247.       if y < 51 then
  248.         inc(y,2000)
  249.       else inc(y,1900);
  250.     case format of
  251.       0: begin
  252.            d := left;
  253.            m := middle;
  254.          end;
  255.       1: begin
  256.            d := middle;
  257.            m := left;
  258.          end;
  259.     end; { case }
  260.   end; { ParseDateString }
  261.  
  262. function NumbOfDaysInMth(y,m : word): byte;
  263.   { valid for the years 1900 - 2078                                   }
  264.   begin
  265.     case m of
  266.       1,3,5,7,8,10,12: NumbOfDaysInMth := 31;
  267.       4,6,9,11       : NumbOfDaysInMth := 30;
  268.       2              : NumbOfDaysInMth := 28 +
  269.                        ord((y mod 4) = 0) - ord(y = 1900);
  270.     end;
  271.   end;
  272.  
  273. function Today : date;
  274.   var y,m,d,dw : word;
  275.   begin
  276.     GetDate(y,m,d,dw);
  277.     Today := PackedDate(y,m,d);
  278.   end;
  279.  
  280. end.  { TCDate unit }
  281.  
  282.    Thanks, TeeCee!
  283.  
  284.  
  285. --- msged 2.07
  286.  * Origin: Hello, Keyboard, my old friend... (1:114/18.10)
  287.  
  288. @PATH: 1079/10 114/18 5 396/1 170/400 512/0 1007 
  289.