home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / PSCAL104 / CALENDAR.PAS < prev    next >
Pascal/Delphi Source File  |  1993-12-18  |  14KB  |  626 lines
  1. {
  2.  
  3. Various Date and Time Procedures
  4.  
  5. Rev. 1.04
  6.  
  7. (c) Copyright 1994, Michael Gallias
  8.  
  9. Target: Real, Protected, Windows
  10.  
  11. }
  12.  
  13. Unit Calendar;
  14.  
  15. Interface
  16.  
  17. {$IFDEF WINDOWS}
  18.  
  19. Uses WinDos, PasStr;
  20.  
  21. {$ELSE}
  22.  
  23. Uses Dos, PasStr;
  24.  
  25. {$ENDIF}
  26.  
  27. Const
  28.   dts_DDMYYYY       =  1;
  29.   dts_DDMMYYYY      =  2;
  30.   dts_DDMMMYYYY     =  3;
  31.  
  32. Type
  33.   TimeDate = Record
  34.                Year,
  35.                Month,
  36.                Day,
  37.                WeekDay,
  38.                Hour,
  39.                Min,
  40.                Sec,
  41.                ms         :Word;
  42.              End;
  43.  
  44.   DayNameString   = String[9];
  45.   DayNameArray    = Array [0..6] of DayNameString;
  46.   MonthNameString = String[10];
  47.   MonthNameArray  = Array [1..12] of MonthNameString;
  48.   MonthAbrString  = String[3];
  49.   MonthAbrArray   = Array [1..12] of MonthAbrString;
  50.  
  51. Const
  52.   DayName     : DayNameArray =
  53.                   ('Sunday', 'Monday', 'Tuesday', 'Wednesday',
  54.                    'Thursday', 'Friday', 'Saturday');
  55.  
  56.   MonthName   : MonthNameArray =
  57.                   ('January', 'February', 'March', 'April', 'May',
  58.                    'June', 'July', 'August', 'September',
  59.                    'October', 'November', 'December');
  60.  
  61.   MonthAbr    : MonthNameArray =
  62.                   ('Jan', 'Feb', 'Mar', 'Apr', 'May',
  63.                    'Jun', 'Jul', 'Aug', 'Sep',
  64.                    'Oct', 'Nov', 'Dec');
  65.  
  66. Procedure StringToDate      (Strg:String; Var Date:TimeDate;
  67.                              Const Style:Byte; Var Code:Integer);
  68. Procedure DateToString      (Date:TimeDate; Var Strg:String; Const Style:Byte);
  69. Procedure StringToTime      (Strg:String; Var Time:TimeDate; Var Code:Integer);
  70. Procedure TimeToString      (Time:TimeDate; Var Strg:String);
  71. Procedure MMDDToDDMM        (DateIn:String; Var DateOut:String);
  72. Procedure GetTimeDate       (Var Time:TimeDate);
  73. Procedure PredMin           (Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  74. Procedure PredHour          (Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  75. Procedure UntotalDays       (Total:LongInt; Var Date:TimeDate);
  76. Procedure DayOfWeek         (Var   Date:TimeDate);
  77. Function  DayOfYear         (Const Date:TimeDate):Word;
  78. Function  TotalMonths       (Const Date:TimeDate):LongInt;
  79. Function  TotalDays         (Const Date:TimeDate):LongInt;
  80. Function  TotalHalfHrs      (Const Time:TimeDate):Byte;
  81. Function  TotalMinutes      (Const Time:TimeDate):Word;
  82. Function  TotalSeconds      (Const Time:TimeDate):LongInt;
  83. Function  Totalms           (Const Time:TimeDate):LongInt;
  84. Function  ChangedTime       (Const Time1, Time2:TimeDate):Boolean;
  85. Function  ChangedTimeDate   (Const Time1, Time2:TimeDate):Boolean;
  86. Function  ChangedDate       (Const Date1, Date2:TimeDate):Boolean;
  87. Function  DaysInMonth       (Month:Byte;Year:Word):Byte;
  88. Function  DaysInYear        (Year:Word):Word;
  89.  
  90. Implementation
  91.  
  92. Procedure StringToDate(Strg:String;Var Date:TimeDate;
  93.                        Const Style:Byte; Var Code:Integer);
  94.  
  95. Var
  96.   SY,SM,SD,ST :String;
  97.   AY,AM,AD,AT :LongInt;
  98.  
  99. Begin
  100.   Code:=0;
  101.   Case Style Of
  102.     dts_DDMMYYYY:
  103.       Begin
  104.         Strg:=Strg+'/';
  105.         SY:='';
  106.         SM:='';
  107.         SD:='';
  108.  
  109.         SD:=Copy(Strg,1,Pos('/',Strg)-1);
  110.         Delete(Strg,1,Pos('/',Strg));
  111.  
  112.         If Pos('/',Strg)>0 Then
  113.         Begin
  114.           SM:=Copy(Strg,1,Pos('/',Strg)-1);
  115.           Delete(Strg,1,Pos('/',Strg));
  116.         End;
  117.  
  118.         If Pos('/',Strg)>0 Then
  119.         Begin
  120.           SY:=Copy(Strg,1,Pos('/',Strg)-1);
  121.           Delete(Strg,1,Pos('/',Strg));
  122.         End;
  123.  
  124.         If SY<>'' Then
  125.         Begin
  126.           If Length(SY)<3 Then SY:='19'+SY;
  127.           Val(SY,AY,Code);
  128.           If (AY<1991) Or (AY>1999) Then Code:=6;
  129.         End
  130.         Else
  131.           Code:=6;
  132.  
  133.         If SM<>'' Then
  134.         Begin
  135.           Val(SM,AM,Code);
  136.           If (AM<1) Or (AM>12) Then Code:=3;
  137.         End
  138.         Else
  139.           Code:=3;
  140.  
  141.         If SD<>'' Then
  142.         Begin
  143.           Val(SD,AD,Code);
  144.           If (AD<1) Or (AD>DaysInMonth(AM,AY)) Then Code:=1;
  145.         End
  146.         Else
  147.           Code:=1;
  148.       End;
  149.     dts_DDMMMYYYY,
  150.     dts_DDMYYYY:
  151.       Begin
  152.         Strg:=Strg+'   ';
  153.         SD:=Copy(Strg,1,Pos(' ',Strg)-1);
  154.         Delete(Strg,1,Pos(' ',Strg));
  155.         SM:=Copy(Strg,1,Pos(' ',Strg)-1);
  156.         Delete(Strg,1,Pos(' ',Strg));
  157.         SY:=Copy(Strg,1,Pos(' ',Strg)-1);
  158.         If (SD='') Or (SM='') Or (SY='') Then
  159.           Code:=99
  160.         Else
  161.         Begin
  162.           UpperCase(SM,SM);
  163.           AT:=0;
  164.           Repeat
  165.             Inc(AT);
  166.             UpperCase(MonthName[AT],ST);
  167.           Until (AT=12) Or (ST=SM);
  168.           If ST<>SM Then
  169.           Begin
  170.             AT:=0;
  171.             Repeat
  172.               Inc(AT);
  173.               UpperCase(MonthAbr[AT],ST);
  174.             Until (AT=12) Or (ST=SM);
  175.           End;
  176.           If ST=SM Then AM:=AT Else Code:=3;
  177.           If Code=0 Then
  178.           Begin
  179.             If Length(SY)<3 Then SY:='19'+SY;
  180.             Val(SY,AY,Code);
  181.             If (AY<1991) Or (AY>1999) Then Code:=6;
  182.           End;
  183.           If Code=0 Then
  184.           Begin
  185.             Val(SD,AD,Code);
  186.             If (AD<1) Or (AD>DaysInMonth(AM,AY)) Then Code:=1;
  187.           End;
  188.         End;
  189.       End;
  190.   End;
  191.   If Code=0 Then
  192.   Begin
  193.     Date.Day   :=AD;
  194.     Date.Month :=AM;
  195.     Date.Year  :=AY;
  196.   End;
  197. End;
  198.  
  199. Procedure DateToString(Date:TimeDate;Var Strg:String;Const Style:Byte);
  200.  
  201. Var
  202.   Temp:String[20];
  203.  
  204. Begin
  205.   Case Style Of
  206.     dts_DDMYYYY:
  207.       Begin
  208.         Str(Date.Day:2,Strg);
  209.         SpacesToZeros(Strg,Strg);
  210.         Temp:=MonthName[Date.Month];
  211.         Strg:=Strg+' '+Temp+' ';
  212.         Str(Date.Year:4,Temp);
  213.         Strg:=Strg+Temp;
  214.       End;
  215.     dts_DDMMYYYY:
  216.       Begin
  217.         Str(Date.Day:2,Strg);
  218.         Str(Date.Month:2,Temp);
  219.         Strg:=Strg+'/'+Temp+'/';
  220.         Str(Date.Year:4,Temp);
  221.         Strg:=Strg+Temp;
  222.         SpacesToZeros(Strg,Strg);
  223.       End;
  224.     dts_DDMMMYYYY:
  225.       Begin
  226.         Str(Date.Day:2,Strg);
  227.         SpacesToZeros(Strg,Strg);
  228.         Temp:=MonthAbr[Date.Month];
  229.         Strg:=Strg+' '+Temp+' ';
  230.         Str(Date.Year:4,Temp);
  231.         Strg:=Strg+Temp;
  232.       End;
  233.   End;
  234. End;
  235.  
  236. Procedure StringToTime(Strg:String;Var Time:TimeDate;Var Code:Integer);
  237.  
  238. Var
  239.   SH,SM,SS:String[10];
  240.   AH,AM,AS:LongInt;
  241.  
  242. Begin
  243.   Strg:=Strg+':';
  244.   SH:='';
  245.   SM:='';
  246.   SS:='';
  247.  
  248.   SH:=Copy(Strg,1,Pos(':',Strg)-1);
  249.   Delete(Strg,1,Pos(':',Strg));
  250.  
  251.   If Pos(':',Strg)>0 Then
  252.   Begin
  253.     SM:=Copy(Strg,1,Pos(':',Strg)-1);
  254.     Delete(Strg,1,Pos(':',Strg));
  255.   End;
  256.  
  257.   If Pos(':',Strg)>0 Then
  258.   Begin
  259.     SS:=Copy(Strg,1,Pos(':',Strg)-1);
  260.     Delete(Strg,1,Pos(':',Strg));
  261.   End;
  262.  
  263.   If SH<>'' Then
  264.   Begin
  265.     Val(SH,AH,Code);
  266.     If (Code>0) Or (AH<0) Or (AH>23) Then Exit;
  267.   End
  268.   Else
  269.     AH:=Time.Hour;
  270.  
  271.   If SM<>'' Then
  272.   Begin
  273.     Val(SM,AM,Code);
  274.     If (Code>0) Or (AM<0) Or (AM>59) Then Exit;
  275.   End
  276.   Else
  277.     AM:=Time.Min;
  278.  
  279.   If SS<>'' Then
  280.   Begin
  281.     Val(SS,AS,Code);
  282.     If (Code>0) Or (AS<0) Or (AS>59) Then Exit;
  283.   End
  284.   Else
  285.     AS:=Time.Sec;
  286.  
  287.   Time.Hour  :=AH;
  288.   Time.Min   :=AM;
  289.   Time.Sec   :=AS;
  290. End;
  291.  
  292. Procedure TimeToString(Time:TimeDate;Var Strg:String);
  293.  
  294. Var
  295.   Temp:String[10];
  296.  
  297. Begin
  298.   Str(Time.Hour:2,Strg);
  299.   Str(Time.Min:2,Temp);
  300.   Strg:=Strg+':'+Temp+':';
  301.   Str(Time.Sec:2,Temp);
  302.   Strg:=Strg+Temp;
  303.   SpacesToZeros(Strg,Strg);
  304. End;
  305.  
  306. Procedure MMDDToDDMM(DateIn:String;Var DateOut:String);
  307.  
  308. Var
  309.   First    :String[12];
  310.   P        :Byte;
  311.  
  312. Begin
  313.   If DateIn='' Then
  314.   Begin
  315.     DateOut:='';
  316.     Exit;
  317.   End;
  318.  
  319.   DateOut:='';
  320.   DateIn:=DateIn+' ';
  321.   P:=Max(Pos(' ',DateIn),Pos('/',DateIn));
  322.   First:=Copy(DateIn,1,P);
  323.   Delete(DateIn,1,P);
  324.  
  325.   Repeat
  326.     P:=Max(Pos(' ',DateIn),Pos('/',DateIn));
  327.     DateOut:=DateOut+Copy(DateIn,1,P);
  328.     Delete(DateIn,1,P);
  329.   Until Length(DateIn)=0;
  330.   P:=Max(Pos(' ',DateOut),Pos('/',DateOut));
  331.   Insert(First,DateOut,P);
  332. End;
  333.  
  334. Procedure GetTimeDate(Var Time:TimeDate);
  335. Begin
  336.   With Time do
  337.   Begin
  338.     GetTime(Hour,Min,Sec,ms);
  339.     GetDate(Year,Month,Day,WeekDay);
  340.   End;
  341. End;
  342.  
  343. Procedure PredMin(Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  344. {Decreases the Time by one Minute, does not check the date if TimeOut.Day=0.}
  345. Begin
  346.   TimeOut:=TimeIn;
  347.   With TimeOut do
  348.   Begin
  349.     If Min>0 Then
  350.       Dec(Min)
  351.     Else
  352.     Begin
  353.       Min:=59;
  354.       If Hour>0 Then
  355.         Dec(Hour)
  356.       Else
  357.       Begin
  358.         Hour:=23;
  359.         If Day>0 Then
  360.         Begin
  361.           If Day>1 Then
  362.             Dec(Day)
  363.           Else
  364.           Begin
  365.             If Month>1 Then
  366.               Dec(Month)
  367.             Else
  368.             Begin
  369.               Month:=12;
  370.               If Year>0 Then Dec(Year);
  371.             End;
  372.             Day:=DaysInMonth(Month,Year);
  373.           End;
  374.         End;
  375.       End;
  376.     End;
  377.   End;
  378. End;
  379.  
  380. Procedure PredHour(Const TimeIn:TimeDate; Var TimeOut:TimeDate);
  381. {Decreases the Time by one Hour, does not check the date if TimeOut.Day=0.}
  382. Begin
  383.   TimeOut:=TimeIn;
  384.   With TimeOut do
  385.   Begin
  386.     If Hour>0 Then
  387.       Dec(Hour)
  388.     Else
  389.     Begin
  390.       Hour:=23;
  391.       If Day>0 Then
  392.       Begin
  393.         If Day>1 Then
  394.           Dec(Day)
  395.         Else
  396.         Begin
  397.           If Month>1 Then
  398.             Dec(Month)
  399.           Else
  400.           Begin
  401.             Month:=12;
  402.             If Year>0 Then Dec(Year);
  403.           End;
  404.           Day:=DaysInMonth(Month,Year);
  405.         End;
  406.       End;
  407.     End;
  408.   End;
  409. End;
  410.  
  411. Procedure UntotalDays(Total:LongInt; Var Date:TimeDate);
  412.  
  413. Const
  414.   t_1000    = 366123;   {Number of days from 0 to 1000, inclusive}
  415.   t_1500    = 549002;
  416.   t_1750    = 640441;
  417.   t_1970    = 720908;
  418.  
  419. Var
  420.   DIY, DIM      :Word;
  421.  
  422. Begin
  423.   FillChar(Date,SizeOf(Date),0);
  424.  
  425.   If Total>t_1970 Then
  426.   Begin
  427.     Dec(Total,t_1970);
  428.     Date.Year:=1971;
  429.   End
  430.   Else
  431.   If Total>t_1750 Then
  432.   Begin
  433.     Dec(Total,t_1750);
  434.     Date.Year:=1751;
  435.   End
  436.   Else
  437.   If Total>t_1500 Then
  438.   Begin
  439.     Dec(Total,t_1500);
  440.     Date.Year:=1501;
  441.   End
  442.   Else
  443.   If Total>t_1000 Then
  444.   Begin
  445.     Dec(Total,t_1000);
  446.     Date.Year:=1001;
  447.   End;
  448.  
  449.   DIY:=DaysInYear(Date.Year);
  450.   While (Total>DIY) do
  451.   Begin
  452.     Dec(Total,DaysInYear(Date.Year));
  453.     Inc(Date.Year);
  454.     DIY:=DaysInYear(Date.Year);
  455.   End;
  456.  
  457.   Date.Month:=1;
  458.   For DIY:=1 to 12 do
  459.   Begin
  460.     DIM:=DaysInMonth(DIY,Date.Year);
  461.     If Total>DIM Then
  462.     Begin
  463.       Dec(Total,DIM);
  464.       Inc(Date.Month);
  465.     End;
  466.   End;
  467.  
  468.   Date.Day:=Total;
  469. End;
  470.  
  471. Procedure DayOfWeek(Var Date:TimeDate);
  472. {Sets 'WeekDay' of Date: 1 for Monday, 0 for Sunday}
  473. Var
  474.   A,B,C    :Word;
  475.   Y,M,D,DOW:Word;
  476.  
  477. Begin
  478.   GetDate(Y,M,D,DOW);
  479.   SetDate(Date.Year,Date.Month,Date.Day);
  480.   GetDate(A,B,C,Date.WeekDay);
  481.   SetDate(Y,M,D);
  482. End;
  483.  
  484. Function DayOfYear(Const Date:TimeDate):Word;
  485.  
  486. Var
  487.   Temp  :Word;
  488.   X     :Byte;
  489.  
  490. Begin
  491.   Temp:=Date.Day;
  492.   For X:=1 to Date.Month-1 do
  493.     Inc(Temp,DaysInMonth(X,Date.Year));
  494.   DayOfYear:=Temp;
  495. End;
  496.  
  497. Function TotalMonths(Const Date:TimeDate):LongInt;
  498. Begin
  499.   TotalMonths:=(12 * (Date.Year - 1)) + Date.Month;
  500. End;
  501.  
  502. Function TotalDays(Const Date:TimeDate):LongInt;
  503.  
  504. {Returns the total number of days that have elapsed from the year 0, including
  505.  the current day, e.g. 1 Jan 0 = 1}
  506.  
  507. Const
  508.   t_1_1_1970    = 720543;
  509.  
  510. Var
  511.   Total:LongInt;
  512.   Year :Integer;
  513.   Month:Byte;
  514.   Start:Integer;
  515.  
  516. Begin
  517.   If Date.Year>=1970 Then
  518.   Begin
  519.     Total:=t_1_1_1970-1;
  520.     Start:=1970;
  521.   End
  522.   Else
  523.   Begin
  524.     Total:=0;
  525.     Start:=0;
  526.   End;
  527.  
  528.   For Year:=Start to Integer(Date.Year)-1 do
  529.     Inc(Total,DaysInYear(Year));
  530.  
  531.   For Month:=1 to Date.Month-1 do
  532.     Inc(Total,DaysInMonth(Month,Date.Year));
  533.   TotalDays:=Total+Date.Day;
  534. End;
  535.  
  536. Function TotalHalfHrs(Const Time:TimeDate):Byte;
  537. Begin
  538.   TotalHalfHrs:=Time.Hour * 2 + (Time.Min Div 30);
  539. End;
  540.  
  541. Function TotalMinutes(Const Time:TimeDate):Word;
  542. Begin
  543.   TotalMinutes:=Time.Hour*60+Time.Min;
  544. End;
  545.  
  546. Function TotalSeconds(Const Time:TimeDate):LongInt;
  547. Begin
  548.   TotalSeconds:=LongInt(Time.Hour)*60*60+LongInt(Time.Min)*60+LongInt(Time.Sec);
  549. End;
  550.  
  551. Function Totalms(Const Time:TimeDate):LongInt;
  552. Begin
  553.   Totalms:=(LongInt(Time.Hour)*60*60+LongInt(Time.Min)*60+LongInt(Time.Sec))*100+LongInt(Time.ms);
  554. End;
  555.  
  556. Function ChangedTime(Const Time1, Time2:TimeDate):Boolean;
  557. Begin
  558.   If (Time1.ms  =Time2.ms  ) And
  559.      (Time1.Sec =Time2.Sec ) And
  560.      (Time1.Min =Time2.Min ) And
  561.      (Time1.Hour=Time2.Hour) Then
  562.     ChangedTime:=False
  563.   Else
  564.     ChangedTime:=True;
  565. End;
  566.  
  567. Function ChangedTimeDate(Const Time1, Time2:TimeDate):Boolean;
  568. Begin
  569.   If (Time1.ms   =Time2.ms   ) And
  570.      (Time1.Sec  =Time2.Sec  ) And
  571.      (Time1.Min  =Time2.Min  ) And
  572.      (Time1.Hour =Time2.Hour ) And
  573.      (Time1.Day  =Time2.Day  ) And
  574.      (Time1.Month=Time2.Month) And
  575.      (Time1.Year =Time2.Year ) Then
  576.     ChangedTimeDate:=False
  577.   Else
  578.     ChangedTimeDate:=True;
  579. End;
  580.  
  581. Function ChangedDate(Const Date1, Date2:TimeDate):Boolean;
  582. Begin
  583.   If (Date1.Day  =Date2.Day  ) And
  584.      (Date1.Month=Date2.Month) And
  585.      (Date1.Year =Date2.Year ) Then
  586.     ChangedDate:=False
  587.   Else
  588.     ChangedDate:=True;
  589. End;
  590.  
  591. Function DaysInMonth(Month:Byte;Year:Word):Byte;
  592. Begin
  593.   Case Month Of
  594.      1:DaysInMonth:=31;
  595.      2:Begin
  596.          If (Year Mod 100)=0 Then      {Centuary}
  597.            If (Year Mod 400)=0 Then
  598.              DaysInMonth:=28
  599.            Else
  600.              DaysInMonth:=29
  601.          Else                          {Non Centuary}
  602.            If (Year Mod 4)=0 Then
  603.              DaysInMonth:=28
  604.            Else
  605.              DaysInMonth:=29;
  606.        End;
  607.      3:DaysInMonth:=31;
  608.      4:DaysInMonth:=30;
  609.      5:DaysInMonth:=31;
  610.      6:DaysInMonth:=30;
  611.      7:DaysInMonth:=31;
  612.      8:DaysInMonth:=31;
  613.      9:DaysInMonth:=30;
  614.     10:DaysInMonth:=31;
  615.     11:DaysInMonth:=30;
  616.     12:DaysInMonth:=31;
  617.   End;
  618. End;
  619.  
  620. Function DaysInYear(Year:Word):Word;
  621. Begin
  622.   If DaysInMonth(2,Year)=29 Then DaysInYear:=366 Else DaysInYear:=365;
  623. End;
  624.  
  625. End.
  626.