home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / DATERTE2.ZIP / DATEROUT.PAS next >
Encoding:
Pascal/Delphi Source File  |  1988-03-29  |  9.2 KB  |  301 lines
  1. Unit DateRout;
  2. Interface
  3. Uses Dos;
  4. Type
  5.   Str3  = String[3];
  6.   Str10 = String[10];
  7.  
  8. Function TdyDate : Str10;
  9. Function LeapYear(CurrYr:LongInt) : Boolean;
  10. Procedure DateComp(Dte1,Dte2:Str10;Var TotDays:LongInt);
  11. Function DateAdd(Dte1:Str10;AddDays:LongInt) : Str10;
  12. Function DowInt(Dte1:Str10) : LongInt;
  13. Function DayName(Dte1:Str10) : Str3;
  14. Function WeekOf(Dte1:Str10;LastDay:LongInt) : Str10;
  15.  
  16. Implementation
  17.  
  18. Const
  19.   BaseYr : LongInt = 1600;
  20.   { Note: Gregorian Calender started 10/15/1582 }
  21. Function TdyDate : Str10;
  22. Var
  23.   Month, Day                    : String[2];
  24.   Year                          : String[4];
  25.   mMonth, mDay, mYear, mDayOfWk : Word;
  26. Begin
  27.   GetDate(mYear,mMonth,mDay,mDayOfWk);
  28.   Str(mMonth,Month);
  29.   Str(mDay,Day);
  30.   Str(mYear,Year);
  31.   If mMonth<10 Then insert('0',Month,1);
  32.   If mDay  <10 Then insert('0',Day,1);
  33.   TdyDate:= Month + '/' + Day + '/' + Year;
  34. End;
  35.  
  36. Procedure DateParse(Date:Str10; Var mmi,ddi,yyi:LongInt);
  37. Var
  38.   mm,dd    : String[2];
  39.   yy       : String[4];
  40.   Ecode    : Integer;
  41. Begin
  42.   mm:= ''; dd:= ''; yy:= '';
  43.   mmi:= 0; ddi:= 0; yyi:= 0;
  44.   mm:= Copy(Date,1,2);  dd:= Copy(Date,4,2);  yy:= Copy(Date,7,4);
  45.   Val(mm,mmi,Ecode);    Val(dd,ddi,Ecode);    Val(yy,yyi,Ecode);
  46. End;
  47.  
  48. Function LeapYear(CurrYr:LongInt):Boolean;
  49. Begin
  50.   LeapYear:= True;
  51.   If (CurrYr mod 4) <> 0 Then LeapYear:= False;
  52.   If (CurrYr mod 100 = 0) and (CurrYr mod 400 <> 0) Then LeapYear:= False;
  53. End;
  54.  
  55. Function DaysFrBase(CurrMM,CurrDD,CurrYY:LongInt):LongInt;
  56. Const
  57.   Days1 : Array[1..12] of Integer=(0,31,59,90,120,151,181,212,243,273,304,334);
  58.   Days2 : Array[1..12] of Integer=(0,31,60,91,121,152,182,213,244,274,305,335);
  59.   Years1 : Array[0..3] of Integer=(0,365,730,1095);
  60.   Years2 : Array[0..3] of Integer=(0,366,731,1096);
  61.   CentArry : Array[0..3] of LongInt=(0,36525,73049,109573);
  62. Var
  63.   MegYrs, CentYrs, QuadYrs, QuadDays,
  64.   MnDays, SubDays, TotYrs, YrDays     : LongInt;
  65. Begin
  66.   QuadDays:= 0;       {shouldn't need to be set, but have to}
  67.   TotYrs:= CurrYY - BaseYr;
  68.   MegYrs:= TotYrs div 400;
  69.   TotYrs:= TotYrs - (MegYrs * 400);
  70.   CentYrs:= TotYrs div 100;
  71.   TotYrs:= TotYrs - (CentYrs * 100);
  72.   QuadYrs:= TotYrs div 4;
  73.   TotYrs:= TotYrs - (QuadYrs * 4);
  74.   Case CentYrs of
  75.        0 : QuadDays:= QuadYrs * 1461;
  76.     1..3 : Case QuadYrs of
  77.                 1 : QuadDays:= 1460;
  78.             2..24 : QuadDays:= (QuadYrs*1461) - 1;
  79.            End;
  80.   End;
  81.   Case CentYrs of
  82.         0 : YrDays:= Years2[TotYrs];
  83.      1..3 : Case QuadYrs of
  84.                   0 : YrDays:= Years1[TotYrs];
  85.               1..24 : YrDays:= Years2[TotYrs];
  86.             End;
  87.   End;
  88.   SubDays:= (MegYrs * 146097) + CentArry[CentYrs] + QuadDays + YrDays;
  89.   If LeapYear(CurrYY) Then MnDays:= Days2[CurrMM] Else MnDays:= Days1[CurrMM];
  90.   DaysFrBase:= SubDays+MnDays+CurrDD;
  91. End;
  92.  
  93. Procedure DateComp(Dte1,Dte2:Str10;Var TotDays:LongInt);
  94. Var
  95.   mmi1, mmi2, ddi1, ddi2, yyi1, yyi2 : LongInt;
  96.   Days1, Days2                       : LongInt;
  97. Begin
  98.   DateParse(Dte1,mmi1,ddi1,yyi1);
  99.   DateParse(Dte2,mmi2,ddi2,yyi2);
  100.   Days1:= DaysFrBase(mmi1,ddi1,yyi1);
  101.   Days2:= DaysFrBase(mmi2,ddi2,yyi2);
  102.   TotDays:= Days2 - Days1;
  103. End;
  104.  
  105. Function ConvertDays(DaysInt:LongInt):Str10;
  106. Const
  107.   MnArray1:Array[1..12] of Integer=(0,31,59,90,120,151,181,212,243,273,304,334);
  108.   MnArray2:Array[1..12] of Integer=(0,31,60,91,121,152,182,213,244,274,305,335);
  109. Var
  110.   MegYrs, CentYrs, QuadYrs,
  111.   SingYrs, FinalYr, MMint          : LongInt;
  112.   MMstr, DDstr                     : String[2];
  113.   YYstr                            : String[4];
  114. Begin
  115.   YYstr:=''; MMstr:= ''; DDstr:= '';
  116.   MegYrs:= DaysInt div 146097;
  117.   DaysInt:= DaysInt - (MegYrs * 146097);
  118.   If (MegYrs > 0) and (DaysInt = 0) Then
  119.   Begin  {mults of 146097 = 12/31/19(+4..)99, must have daysint=146097 to eval}
  120.     Dec(MegYrs);
  121.     DaysInt:= 146097;
  122.   End;
  123.   If DaysInt < 36526 Then CentYrs:= 0
  124.   Else
  125.    If DaysInt < 73050 Then
  126.    Begin
  127.      CentYrs:= 1;
  128.      Dec(DaysInt,36525);
  129.    End
  130.    Else
  131.      If DaysInt < 109574 Then
  132.      Begin
  133.        CentYrs:= 2;
  134.        Dec(DaysInt,73049);
  135.      End
  136.      Else
  137.        Begin
  138.          CentYrs:= 3;
  139.          Dec(DaysInt,109573);
  140.        End;
  141.   Case CentYrs of
  142.        0 : Begin
  143.              QuadYrs:= DaysInt div 1461;
  144.              DaysInt:= DaysInt - (QuadYrs * 1461);
  145.            End;
  146.     1..3 : Case DaysInt of
  147.                 0..1460 : QuadYrs:= 0;
  148.              1461..2921 : Begin
  149.                             QuadYrs:= 1;
  150.                             Dec(DaysInt,1460);
  151.                           End;
  152.                     Else  Begin
  153.                             Dec(DaysInt,1460);
  154.                             QuadYrs:= DaysInt div 1461;
  155.                             DaysInt:= DaysInt - (QuadYrs * 1461);
  156.                             Inc(QuadYrs);
  157.                           End;
  158.            End;
  159.   End;
  160.   If (QuadYrs = 25) and (DaysInt = 0) Then
  161.   Begin  {mults of 1461 = 12/31/16(+1..)99, must have daysint=1461 to eval}
  162.     QuadYrs:= 24;
  163.     DaysInt:= 1461;
  164.   End;
  165.   Case CentYrs of
  166.        0 : Case DaysInt of
  167.                 0..366 : SingYrs:= 0;
  168.               367..731 : Begin
  169.                            SingYrs:= 1;
  170.                            Dec(DaysInt,366);
  171.                          End;
  172.              732..1096 : Begin
  173.                            SingYrs:= 2;
  174.                            Dec(DaysInt,731);
  175.                          End;
  176.                     Else Begin
  177.                            SingYrs:= 3;
  178.                            Dec(DaysInt,1096);
  179.                          End;
  180.            End;
  181.     1..3 : Case QuadYrs of
  182.              0 : Case DaysInt of
  183.                      0..365 : SingYrs:= 0;
  184.                    366..730 : Begin
  185.                                 SingYrs:= 1;
  186.                                 Dec(DaysInt,365);
  187.                               End;
  188.                   731..1095 : Begin
  189.                                 SingYrs:= 2;
  190.                                 Dec(DaysInt,730);
  191.                               End;
  192.                          Else Begin
  193.                                 SingYrs:= 3;
  194.                                 Dec(DaysInt,1095);
  195.                               End;
  196.                  End;
  197.          1..24 : Case DaysInt of
  198.                      0..366 : SingYrs:= 0;
  199.                    367..731 : Begin
  200.                                 SingYrs:= 1;
  201.                                 Dec(DaysInt,366);
  202.                               End;
  203.                   731..1096 : Begin
  204.                                 SingYrs:= 2;
  205.                                 Dec(DaysInt,731);
  206.                               End;
  207.                          Else Begin
  208.                                 SingYrs:= 3;
  209.                                 Dec(DaysInt,1096);
  210.                               End;
  211.                  End;
  212.            End;
  213.   End;
  214.   FinalYr:= BaseYr+(MegYrs * 400) + (CentYrs * 100) + (QuadYrs * 4) + SingYrs;
  215.   Str(FinalYr,YYstr);
  216.   If LeapYear(FinalYr) Then
  217.   Begin
  218.     Case DaysInt of
  219.          1..31 : MMint:= 1;  {-0}
  220.         32..60 : MMint:= 2;  {-31}
  221.         61..91 : MMint:= 3;  {-60}
  222.        92..121 : MMint:= 4;  {-91}
  223.       122..152 : MMint:= 5;  {-121}
  224.       153..182 : MMint:= 6;  {-152}
  225.       183..213 : MMint:= 7;  {-182}
  226.       214..244 : MMint:= 8;  {-213}
  227.       245..274 : MMint:= 9;  {-244}
  228.       275..305 : MMint:= 10; {-274}
  229.       306..335 : MMint:= 11; {-305}
  230.       336..366 : MMint:= 12; {-335}
  231.     End;
  232.     DaysInt:= DaysInt - MnArray2[MMint];
  233.   End
  234.   Else
  235.   Begin
  236.     Case DaysInt of
  237.          1..31 : MMint:= 1;  {-0}
  238.         32..59 : MMint:= 2;  {-31}
  239.         60..90 : MMint:= 3;  {-59}
  240.        91..120 : MMint:= 4;  {-90}
  241.       121..151 : MMint:= 5;  {-120}
  242.       152..181 : MMint:= 6;  {-151}
  243.       182..212 : MMint:= 7;  {-181}
  244.       213..243 : MMint:= 8;  {-212}
  245.       244..273 : MMint:= 9;  {-243}
  246.       274..304 : MMint:= 10; {-273}
  247.       305..334 : MMint:= 11; {-304}
  248.       335..365 : MMint:= 12; {-334}
  249.     End;
  250.     DaysInt:= DaysInt - MnArray1[MMint];
  251.   End;
  252.   Str(MMint,MMstr);
  253.   If MMint < 10 Then MMstr:= '0' + MMstr;
  254.   Str(DaysInt,DDstr);
  255.   If DaysInt < 10 Then DDstr:= '0' + DDstr;
  256.   ConvertDays:= MMstr + '/' + DDstr + '/' + YYstr;
  257. End;
  258.  
  259. Function DateAdd(Dte1:Str10;AddDays:LongInt):Str10;
  260. Var
  261.   OrigDays, NewDays,
  262.   MMi, DDi, YYi      : LongInt;
  263. Begin
  264.   DateParse(Dte1,MMi,DDi,YYi);
  265.   OrigDays:= DaysFrBase(MMi,DDi,YYi);
  266.   NewDays:= OrigDays + AddDays;
  267.   DateAdd:= ConvertDays(NewDays);
  268. End;
  269.  
  270. Function DowInt(Dte1:Str10):LongInt;
  271. Var
  272.   mmi, ddi, yyi : LongInt;
  273.   Days          : LongInt;
  274. Begin
  275.   DateParse(Dte1,mmi,ddi,yyi);
  276.   Days:= DaysFrBase(mmi,ddi,yyi) + 5;
  277.   DowInt:= Days mod 7;
  278. End;
  279.  
  280. Function DayName(Dte1:Str10):Str3;
  281. Const
  282.   DayStr : Array[0..6] of Str3 = ('Sun','Mon','Tue','Wed','Thr','Fri','Sat');
  283. Var
  284.   I : LongInt;
  285. Begin
  286.   I:= DowInt(Dte1);
  287.   DayName:= DayStr[I]
  288. End;
  289.  
  290. Function WeekOf(Dte1:Str10;LastDay:LongInt):Str10;
  291. Var                             { Caution:                     }
  292.   Days, Accum,                  { won't work on first days in  }
  293.   MMi, DDi, YYi  : LongInt;     { year 1600 if weekof falls in }
  294. Begin                           { year 1599                    }
  295.   DateParse(Dte1,MMi,DDi,YYi);
  296.   Days:= DaysFrBase(MMi,DDi,YYi);
  297.   Accum:= (Days + LastDay) - DowInt(Dte1);
  298.   WeekOf:= ConvertDays(Accum);
  299. End;
  300.  
  301. End{Unit}.