home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / database / edit_22 / dates.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-05-28  |  3.2 KB  |  128 lines
  1. Unit Dates;
  2.  
  3. Interface
  4.  
  5. Uses
  6.   Crt,Dos;
  7.  
  8. Const
  9.   DayArray : Array[1..12] of Integer = (31,28,31,30,31,30,31,31,30,31,30,31);
  10.   WeekArray : Array[0..6]  of String[9] = ('Sunday', 'Monday', 'Tuesday',
  11.                          'Wednesday','Thursday','Friday','Saturday');
  12.   MonthArray : Array[1..12] of String[9] = ('January','February','March','April',
  13.                          'May','June','July','August','September','October',
  14.                          'November','December');
  15.  
  16. Type
  17.   DateStr = String[10];
  18.  
  19. Procedure DateToInt(Date : DateStr; Var Month,Day,Year : Integer);
  20. Function IntToDate(M,D,Y : Integer): DateStr;
  21. Function ToJulian(M,D,Y : Integer): Real;
  22. Procedure FromJulian(X : Real; Var M,D,Y : Integer);
  23. Function DayOfTheWeek(Month,Day,Year : Integer): Integer;
  24. Function CurrentDate : DateStr;
  25.  
  26. Implementation
  27.  
  28. Procedure DateToInt(Date : DateStr; Var Month,Day,Year : Integer);
  29. Var
  30.   Position : Integer;
  31.  
  32.   Function Parsedate(Var I : Integer; Dat : DateStr): Integer;
  33.   Var
  34.     Num : Word;
  35.   Begin
  36.     While not (Dat[I] in ['0'..'9']) and (I <= Length(Date)) do I := I + 1;
  37.     Num := 0;
  38.     While (Dat[I] in ['0'..'9']) and (I <= Length(Date)) do
  39.     Begin
  40.       Num := (Ord(Dat[I]) - Ord('0')) + (Num * 10);
  41.       I := I + 1;
  42.     End;
  43.     ParseDate := Num;
  44.   End;
  45.  
  46. Begin
  47.   Position := 1;
  48.   Month := ParseDate(Position,Date);
  49.   Day   := ParseDate(Position,Date);
  50.   Year  := ParseDate(Position,Date);
  51.   If Year < 100 then Year := Year + 1900;
  52. End;
  53.  
  54. Function IntToDate(M,D,Y : Integer): DateStr;
  55. Var
  56.   Mo,Da,Yr : String[2];
  57.   Date     : DateStr;
  58. Begin
  59.   If Y < 100 then Y := Y + 1900;
  60.   Str(M,Mo);
  61.   Str(D,Da);
  62.   Str(Y,Yr);
  63.   IntToDate := Mo + '/' + Da + '/' + Yr;
  64. End;
  65.  
  66. Function ToJulian(M,D,Y : Integer): Real;
  67. Var
  68.   X : Real;
  69.   I : Word;
  70. Begin
  71.   X := Int((Y * 365.25) - Int(Y/100)) - 1;
  72.   For I := 1 to M-1 do X := X + DayArray[I];
  73.   X := X + D;
  74.   If (Int(Y/4) = Y/4) and (M > 2) then X := X + 1;
  75.   ToJulian := X;
  76. End;
  77.  
  78. Procedure FromJulian(X : Real; Var M,D,Y : Integer);
  79. Var
  80.   I,J,K : Integer;
  81. Begin
  82.   Y := Round(X / 365.25);
  83.   J := Round((X - (Y * 365.25)) + Int(Y/100));
  84.   If Int(Y/4) = Y/4 then J := J + 1 else J := J + 2;
  85.   K := 1;
  86.   If (Int(Y/4) = Y/4) then DayArray[2] := 29;
  87.   While J > DayArray[K] do
  88.   Begin
  89.     J := J - DayArray[K];
  90.     K := K + 1;
  91.   End;
  92.   If K > 12 then begin K := 1; Y := Y + 1; End;
  93.   M := K;
  94.   D := J;
  95. End;
  96.  
  97. Function DayOfTheWeek(Month,Day,Year : Integer): Integer;
  98. Var
  99.   Century : Integer;
  100. Begin
  101.   If Month > 2 then Month := Month - 2 else
  102.   Begin
  103.     Month := Month + 10;
  104.     Year  := Pred(Year);
  105.   End;
  106.   Century := Year Div 100;
  107.   Year    := Year Mod 100;
  108.   DayOfTheWeek := (Day - 1 + ((13 * Month - 1) Div 5) + (5 * Year Div 4) +
  109.                Century Div 4 - 2 * Century + 1) Mod 7;
  110. End;
  111.  
  112. Function CurrentDate : DateStr;
  113. Var
  114.   I,Year,Month,Day,DayOfWeek : Word;
  115.   CDate : String[8];
  116.   M,D,Y : String[2];
  117. Begin
  118.   Getdate(Year,Month,Day,DayOfWeek);
  119.   Str(Month:2,M);
  120.   Str(Day:2,D);
  121.   Str((Year - 1900):2,Y);
  122.   CDate := M + '/' + D + '/' + Y;
  123.   For I := 1 to Length(CDate) do if CDate[I] = ' ' then CDate[I] := '0';
  124.   CurrentDate := CDate;
  125. End;
  126.  
  127. End.
  128.