home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GREGDATE.ZIP / DATEROUT.PAS next >
Encoding:
Pascal/Delphi Source File  |  1988-01-15  |  7.4 KB  |  239 lines
  1. Unit DateRout;
  2.  
  3.  { This set of routines is placed in the public domain by:  }
  4.  {     John Wood                                            }
  5.  {     14720 Karyl Dr.                                      }
  6.  {     Minnetonka, MN  55345                                }
  7.  { If you have any suggestions for improvements or          }
  8.  { additions, please write me at this address.   Enjoy!     }
  9.  {                                                          }
  10.  { I wrote these routines to circumvent the dos date        }
  11.  { limitation of 1980 thru 2100.  I believe these routines  }
  12.  { correctly deal with Gregorian dates from year 1590       }
  13.  { forward.  The TdyDate function is the only routine       }
  14.  { that uses dos - I figured we'd probably have a new       }
  15.  { version of dos to determine today's date by year 2100... }
  16.  {                                                          }
  17.  { DateParse & DaysFrBase are really internal routines.  I  }
  18.  { left the declarations in the public section to help      }
  19.  { with my own testing - you may want to make them private. }
  20.  
  21. Interface
  22. Uses Dos;
  23. Type
  24.   Str2  = String[2];
  25.   Str3  = String[3];
  26.   Str4  = String[4];
  27.   Str8  = String[8];
  28.   Str10 = String[10];
  29.  
  30. Function TdyDate : Str10;
  31. Procedure DateParse(Date:Str10; Var mmi,ddi,yyi:LongInt);
  32. Function LeapYear(CurrYr:LongInt):Boolean;
  33. Function DaysFrBase(CurrMM,CurrDD,CurrYY:LongInt):LongInt;
  34. Procedure DateComp(Dte1,Dte2:Str10;Var TotDays:LongInt);
  35. Function ConvertDays(DaysInt:LongInt):Str10;
  36. Function DateAdd(Dte1:Str10;AddDays:LongInt):Str10;
  37. Function DowInt(Dte1:Str10):LongInt;
  38. Function DayName(Dte1:Str10):Str3;
  39. Function WeekOf(Dte1:Str10;LastDay:LongInt):Str10;
  40.  
  41. Implementation
  42.  
  43. Const
  44.   BaseYr : LongInt = 1590;
  45.   { Note: Gregorian Calender started 10/15/1582                }
  46. Function TdyDate : Str10;
  47. Var
  48.   Month, Day                    : Str2;
  49.   Year                          : Str4;
  50.   mMonth, mDay, mYear, mDayOfWk : Word;
  51. Begin
  52.   GetDate(mYear,mMonth,mDay,mDayOfWk);
  53.   Str(mMonth,Month);
  54.   Str(mDay,Day);
  55.   Str(mYear,Year);
  56.   If mMonth<10 Then insert('0',Month,1);
  57.   If mDay  <10 Then insert('0',Day,1);
  58.   TdyDate := Month + '/' + Day + '/' + Year;
  59. End;
  60.  
  61. Procedure DateParse(Date:Str10; Var mmi,ddi,yyi:LongInt);
  62. Var
  63.   mm,dd    : Str2;
  64.   yy       : Str4;
  65.   Ecode    : Integer;
  66. Begin
  67.   mm:= ''; dd:= ''; yy:= '';
  68.   mmi:= 0; ddi:= 0; yyi:= 0;
  69.   mm:= Copy(Date,1,2); dd:= Copy(Date,4,2); yy:= Copy(Date,7,4);
  70.   Val(mm,mmi,Ecode);  Val(dd,ddi,Ecode);  Val(yy,yyi,Ecode);
  71. End;
  72.  
  73. Function LeapYear(CurrYr:LongInt):Boolean;
  74. Begin
  75.   LeapYear:= True;
  76.   If (CurrYr mod 4) <> 0 Then LeapYear:= False;
  77.   If (CurrYr mod 100 = 0) and (CurrYr mod 400 <> 0) Then LeapYear:= False;
  78. End;
  79.  
  80. Function DaysFrBase(CurrMM,CurrDD,CurrYY:LongInt):LongInt;
  81. Const
  82.   Days1 : Array[1..12] of Integer=(0,31,59,90,120,151,181,212,243,273,304,334);
  83.   Days2 : Array[1..12] of Integer=(0,31,60,91,121,152,182,213,244,274,305,335);
  84.   Years : Array[0..3] of Integer=(0,365,730,1096);
  85. Var
  86.   CentYrs, QuadYrs, MnDays,
  87.   SubDays, TotYrs           : LongInt;
  88. Begin
  89.   MnDays:= 0; CentYrs:= 0; QuadYrs:= 0; SubDays:= 0; TotYrs:= 0;
  90.   TotYrs:= CurrYY - BaseYr;
  91.   CentYrs:= TotYrs div 400;
  92.   TotYrs:= TotYrs - (CentYrs * 400);
  93.   QuadYrs:= TotYrs div 4;
  94.   TotYrs:= TotYrs - (QuadYrs * 4);
  95.   SubDays:= (CentYrs * 146097) + (QuadYrs * 1461) + Years[TotYrs];
  96.   If LeapYear(CurrYY) Then MnDays:= Days2[CurrMM] Else MnDays:= Days1[CurrMM];
  97.   DaysFrBase:= SubDays+MnDays+CurrDD;
  98. End;
  99.  
  100. Procedure DateComp(Dte1,Dte2:Str10;Var TotDays:LongInt);
  101. Var
  102.   mmi1, mmi2, ddi1, ddi2, yyi1, yyi2 : LongInt;
  103.   Days1, Days2                       : LongInt;
  104. Begin
  105.   mmi1:= 0; mmi2:= 0; ddi1:= 0; ddi2:= 0; yyi1:= 0; yyi2:= 0;
  106.   TotDays:= 0; Days1:= 0; Days2:= 0;
  107.   DateParse(Dte1,mmi1,ddi1,yyi1);
  108.   DateParse(Dte2,mmi2,ddi2,yyi2);
  109.   Days1:= DaysFrBase(mmi1,ddi1,yyi1);
  110.   Days2:= DaysFrBase(mmi2,ddi2,yyi2);
  111.   TotDays:= Days2 - Days1;
  112. End;
  113.  
  114. Function ConvertDays(DaysInt:LongInt):Str10;
  115. Const
  116.   MnArray1:Array[1..12] of Integer=(0,31,59,90,120,151,181,212,243,273,304,334);
  117.   MnArray2:Array[1..12] of Integer=(0,31,60,91,121,152,182,213,244,274,305,335);
  118. Var
  119.   QuadYrs, CentYrs,
  120.   FinalYr, MMint, DDint            : LongInt;
  121.   MMstr, DDstr                     : Str2;
  122.   YYstr                            : Str4;
  123. Begin
  124.   YYstr:=''; MMstr:= ''; DDstr:= ''; DDint:= 0;
  125.   CentYrs:= DaysInt div 146097;
  126.   DaysInt:= DaysInt - (CentYrs * 146097);
  127.   QuadYrs:= DaysInt div 1461;
  128.   DaysInt:= DaysInt - (QuadYrs * 1461);
  129.   Case DaysInt of
  130.              0 : Begin
  131.                    FinalYr:= BaseYr - 1;
  132.                    DaysInt:= 365;
  133.                  End;
  134.         1..365 : FinalYr:= BaseYr;
  135.       366..730 : Begin
  136.                    FinalYr:= BaseYr + 1;
  137.                    DaysInt:= DaysInt - 365;
  138.                  End;
  139.      731..1096 : Begin
  140.                    FinalYr:= BaseYr + 2;
  141.                    DaysInt:= DaysInt - 730;
  142.                  End;
  143.     1097..1461 : Begin
  144.                    FinalYr:= BaseYr + 3;
  145.                    DaysInt:= DaysInt - 1096;
  146.                  End;
  147.   End;
  148.   FinalYr:= FinalYr + (CentYrs * 400) + (QuadYrs * 4);
  149.   Str(FinalYr,YYstr);
  150.   If LeapYear(FinalYr) Then
  151.   Begin
  152.     Case DaysInt of
  153.         1..31  : MMint:= 1;  {-0}
  154.        32..60  : MMint:= 2;  {-31}
  155.        61..91  : MMint:= 3;  {-60}
  156.        92..121 : MMint:= 4;  {-91}
  157.       122..152 : MMint:= 5;  {-121}
  158.       153..182 : MMint:= 6;  {-152}
  159.       183..213 : MMint:= 7;  {-182}
  160.       214..244 : MMint:= 8;  {-213}
  161.       245..274 : MMint:= 9;  {-244}
  162.       275..305 : MMint:= 10; {-274}
  163.       306..335 : MMint:= 11; {-305}
  164.       336..366 : MMint:= 12; {-335}
  165.     End;
  166.     DaysInt:= DaysInt - MnArray2[MMint];
  167.   End
  168.   Else
  169.   Begin
  170.     Case DaysInt of
  171.         1..31  : MMint:= 1;  {-0}
  172.        32..59  : MMint:= 2;  {-31}
  173.        60..90  : MMint:= 3;  {-59}
  174.        91..120 : MMint:= 4;  {-90}
  175.       121..151 : MMint:= 5;  {-120}
  176.       152..181 : MMint:= 6;  {-151}
  177.       182..212 : MMint:= 7;  {-181}
  178.       213..243 : MMint:= 8;  {-212}
  179.       244..273 : MMint:= 9;  {-243}
  180.       274..304 : MMint:= 10; {-273}
  181.       305..334 : MMint:= 11; {-304}
  182.       335..365 : MMint:= 12; {-334}
  183.     End;
  184.     DaysInt:= DaysInt - MnArray1[MMint];
  185.   End;
  186.   DDint:= DaysInt;
  187.   Str(MMint,MMstr);
  188.   If MMint < 10 Then MMstr:= '0'+MMstr;
  189.   Str(DDint,DDstr);
  190.   If DDint < 10 Then DDstr:= '0'+DDstr;
  191.   ConvertDays:= MMstr+'/'+DDstr+'/'+YYstr;
  192. End;
  193.  
  194. Function DateAdd(Dte1:Str10;AddDays:LongInt):Str10;
  195. Var
  196.   OrigDays, NewDays : LongInt;
  197.   MMi, DDi, YYi     : LongInt;
  198. Begin
  199.   OrigDays:= 0; NewDays:= 0; MMi:= 0; DDi:= 0; YYi:= 0;
  200.   DateParse(Dte1,MMi,DDi,YYi);
  201.   OrigDays:= DaysFrBase(MMi,DDi,YYi);
  202.   NewDays:= OrigDays + AddDays;
  203.   DateAdd:= ConvertDays(NewDays);
  204. End;
  205.  
  206. Function DowInt(Dte1:Str10):LongInt;
  207. Var
  208.   mmi, ddi, yyi : LongInt;
  209.   Days          : LongInt;
  210. Begin
  211.   DateParse(Dte1,mmi,ddi,yyi);
  212.   Days:= DaysFrBase(mmi,ddi,yyi)+4; {+4 is adjustment for BaseYr = 1590}
  213.   DowInt:= Days mod 7;
  214. End;
  215.  
  216. Function DayName(Dte1:Str10):Str3;
  217. Const
  218.   DayStr : Array[0..6] of Str3 = ('Sun','Mon','Tue','Wed','Thr','Fri','Sat');
  219. Var
  220.   I : LongInt;
  221. Begin
  222.   I:= DowInt(Dte1);
  223.   DayName:= DayStr[I]
  224. End;
  225.  
  226. Function WeekOf(Dte1:Str10;LastDay:LongInt):Str10;
  227. Var
  228.   Days, Accum    : LongInt;
  229.   MMi, DDi, YYi  : LongInt;
  230. Begin
  231.   Days:= 0; Accum:= 0;
  232.   DateParse(Dte1,MMi,DDi,YYi);
  233.   Days:= DaysFrBase(MMi,DDi,YYi);
  234.   Accum:= (Days + LastDay) - DowInt(Dte1);
  235.   WeekOf:= ConvertDays(Accum);
  236. End;
  237.  
  238. End. {of unit}
  239.