home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / datetime.swg / 0007_DATE6.PAS.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  7.6 KB  |  267 lines
  1. Unit Julian;
  2. {DEMO Routines
  3. /begin
  4. /  ClrScr;
  5. /  GetDate(Year,Month,Day,Dow);
  6. /  WriteLn('Year  : ',Year);
  7. /  WriteLn('Month : ',Month);
  8. /  WriteLn('Day   : ',Day);
  9. /  WriteLn('doW   : ',Dow);
  10. /  WriteLn(MachineDate);
  11. /  JulianDate := DatetoJulian(MachineDate);
  12. /  WriteLn('Julian Date = ',JulianDate);
  13. /  WriteLn('Jul to Date = ',JuliantoDate(JulianDate));
  14. /  WriteLn('Day of Week = ',DayofWeek(JulianDate));
  15. /  WriteLn('Time        = ',MachineTime(4));
  16. /end.}
  17. Interface
  18.  
  19. Uses Crt, Dos;
  20.  
  21. Type
  22.   Str3  = String[3];
  23.   Str8  = String[8];
  24.   Str9  = String[9];
  25.   Str11 = String[11];
  26.  
  27. Var
  28.   Hour,Minute,Second,S100,
  29.   Year,Month,Day,Dow     : Word;
  30.   Syear,Smonth,Sday,Sdow : String;
  31.   JulianDate             : Integer;
  32.  
  33. Function MachineTime(Len : Byte) : Str11;
  34. Function MachineDate : Str8;
  35. Function DateFactor(MonthNum, DayNum, YearNum : Real) : Real;
  36. Function DatetoJulian(DateLine : Str8) : Integer;
  37. Function JuliantoDate(DateInt : Integer): Str11;
  38. Function JuliantoStr8(DateInt : Integer): Str8;
  39. Function DayofWeek(Jdate : Integer) : Str3;
  40. Procedure DateDiff(Date1,Date2 : Integer; Var Date_Difference : Str9);
  41.  
  42. Implementation
  43. Function MachineTime(Len : Byte) : Str11;
  44. Var
  45.   I       : Byte;
  46.   TempStr : String;
  47.   TimeStr : Array[1..4] of String;
  48. begin
  49.   TempStr := ''; FillChar(TimeStr,Sizeof(TimeStr),0);
  50.   GetTime(Hour,Minute,Second,S100);
  51.   Str(Hour,TimeStr[1]);
  52.   Str(Minute,TimeStr[2]);
  53.   Str(Second,TimeStr[3]);
  54.   Str(S100,TimeStr[4]);
  55.   TempStr := TimeStr[1];
  56.   For I := 2 to Len Do TempStr := TempStr + ':' + TimeStr[I];
  57.   MachineTime := TempStr;
  58. end;
  59.  
  60. Function MachineDate : Str8;
  61. begin
  62.   GetDate(Year,Month,Day,Dow);
  63.   Str(Year,Syear);
  64.   Str(Month,Smonth);
  65.   if Month < 10 then Smonth := '0' + Smonth;
  66.   Str(Day,Sday);
  67.   if Day < 10 then Sday := '0' + Sday;
  68.   MachineDate := smonth + sday + syear;
  69. end;
  70.  
  71. Function DateFactor(MonthNum, DayNum, YearNum : Real) : Real;
  72. Var
  73.  Factor : Real;
  74. begin
  75.  Factor :=   (365 * YearNum)
  76.            + DayNum
  77.            + (31 * (MonthNum-1));
  78.  if MonthNum < 3
  79.   then Factor :=  Factor
  80.                 + Int((YearNum-1) / 4)
  81.                 - Int(0.75 * (Int((YearNum-1) / 100) + 1))
  82.   else Factor :=  Factor
  83.                 - Int(0.4 * MonthNum + 2.3)
  84.                 + Int(YearNum / 4)
  85.                 - Int(0.75 * (Int(YearNum / 100) + 1));
  86.  DateFactor := Factor;
  87. end;
  88.  
  89. Function DatetoJulian(DateLine : Str8) : Integer;
  90. Var
  91.  Factor, MonthNum, DayNum, YearNum : Real;
  92.  Ti : Integer;
  93. begin
  94.  if Length(DateLine) = 7
  95.   then DateLine := '0'+DateLine;
  96.  MonthNum := 0.0;
  97.  For Ti := 1 to 2 Do
  98.   MonthNum := (10 * MonthNum)
  99.     + (ord(DateLine[Ti])-ord('0'));
  100.  DayNum := 0.0;
  101.  For Ti := 3 to 4 Do
  102.   DayNum := (10 * DayNum)
  103.     + (ord(DateLine[Ti])-ord('0'));
  104.  YearNum := 0.0;
  105.  For Ti := 5 to 8 Do
  106.   YearNum := (10 * YearNum)
  107.     + (ord(DateLine[Ti])-ord('0'));
  108.  Factor := DateFactor(MonthNum, DayNum, YearNum);
  109.  DatetoJulian :=
  110.   Trunc((Factor - 679351.0) - 32767.0);
  111. end;
  112.  
  113. Function JuliantoDate(DateInt : Integer): Str11;
  114. Var
  115.  holdstr  : String[2];
  116.  anystr  : String[11];
  117.  StrMonth : String[3];
  118.  strDay   : String[2];
  119.  stryear  : String[4];
  120.  test,
  121.  error,
  122.  Year,
  123.  Dummy,
  124.  I       : Integer;
  125.  Save,Temp    : Real;
  126.  JuliantoanyString : Str11;
  127. begin
  128.  holdstr := '';
  129.  JuliantoanyString := '00000000000';
  130.  Temp  := Int(DateInt) + 32767 + 679351.0;
  131.  Save  := Temp;
  132.  Dummy := Trunc(Temp/365.5);
  133.  While Save >= DateFactor(1.0,1.0,Dummy+0.0)
  134.   Do Dummy := Succ(Dummy);
  135.  Dummy := Pred(Dummy);
  136.  Year  := Dummy;
  137.  (* Determine number of Days into current year *)
  138.  Temp  := 1.0 + Save - DateFactor(1.0,1.0,Year+0.0);
  139.  (* Put the Year into the output String *)
  140.  For I := 8 downto 5 Do
  141.   begin
  142.    JuliantoanyString[I]
  143.     := Char((Dummy mod 10)+ord('0'));
  144.    Dummy := Dummy div 10;
  145.   end;
  146.  Dummy := 1 + Trunc(Temp/31.5);
  147.  While Save >= DateFactor(Dummy+0.0,1.0,Year+0.0)
  148.   Do Dummy := Succ(Dummy);
  149.  Dummy := Pred(Dummy);
  150.  Temp  := 1.0 + Save - DateFactor(Dummy+0.0,1.0,Year+0.0);
  151.  For I := 2 Downto 1 Do
  152.   begin
  153.    JuliantoanyString[I]
  154.     := Char((Dummy mod 10)+ord('0'));
  155.    Dummy := Dummy div 10;
  156.   end;
  157.  Dummy := Trunc(Temp);
  158.  For I := 4 Downto 3 Do
  159.   begin
  160.    JuliantoanyString[I]
  161.     := Char((Dummy mod 10)+ord('0'));
  162.    Dummy := Dummy div 10;
  163.   end;
  164.   holdstr := copy(juliantoanyString,1,2);
  165.   val(holdstr,test,error);
  166.   Case test of
  167.     1 : StrMonth := 'Jan';
  168.     2 : StrMonth := 'Feb';
  169.     3 : StrMonth := 'Mar';
  170.     4 : StrMonth := 'Apr';
  171.     5 : StrMonth := 'May';
  172.     6 : StrMonth := 'Jun';
  173.     7 : StrMonth := 'Jul';
  174.     8 : StrMonth := 'Aug';
  175.     9 : StrMonth := 'Sep';
  176.    10 : StrMonth := 'Oct';
  177.    11 : StrMonth := 'Nov';
  178.    12 : StrMonth := 'Dec';
  179.   end;
  180.   stryear := copy(juliantoanyString,5,4);
  181.   strDay  := copy(juliantoanyString,3,2);
  182.   anystr := StrDay + '-' + StrMonth + '-' +stryear;
  183.  JuliantoDate := anystr;
  184. end;
  185.  
  186. Function JuliantoStr8(DateInt : Integer): Str8;
  187. Var
  188.  holdstr  : String[2]; anystr   : String[8]; StrMonth : String[2];
  189.  strDay   : String[2]; stryear  : String[4]; Save, Temp : Real;
  190.  test, error, Year, Dummy, I : Integer; JuliantoanyString : Str8;
  191. begin
  192.  holdstr := ''; JuliantoanyString := '00000000';
  193.  Temp  := Int(DateInt) + 32767 + 679351.0;
  194.  Save  := Temp; Dummy := Trunc(Temp/365.5);
  195.  While Save >= DateFactor(1.0,1.0,Dummy+0.0) Do Dummy := Succ(Dummy);
  196.  Dummy := Pred(Dummy); Year  := Dummy;
  197.  Temp  := 1.0 + Save - DateFactor(1.0,1.0,Year+0.0);
  198.  For I := 8 downto 5 Do
  199.   begin
  200.    JuliantoanyString[I] := Char((Dummy mod 10)+ord('0'));
  201.    Dummy := Dummy div 10;
  202.   end;
  203.  Dummy := 1 + Trunc(Temp/31.5);
  204.  While Save >= DateFactor(Dummy+0.0,1.0,Year+0.0) Do Dummy := Succ(Dummy);
  205.  Dummy := Pred(Dummy);
  206.  Temp  := 1.0 + Save - DateFactor(Dummy+0.0,1.0,Year+0.0);
  207.  For I := 2 Downto 1 Do
  208.   begin
  209.    JuliantoanyString[I] := Char((Dummy mod 10)+ord('0'));
  210.    Dummy := Dummy div 10;
  211.   end;
  212.  Dummy := Trunc(Temp);
  213.  For I := 4 Downto 3 Do
  214.   begin
  215.    JuliantoanyString[I] := Char((Dummy mod 10)+ord('0'));
  216.    Dummy := Dummy div 10;
  217.   end;
  218.   holdstr := copy(juliantoanyString,1,2); val(holdstr,test,error);
  219.   Case test of
  220.   1 : StrMonth := '01'; 2 : StrMonth := '02'; 3 : StrMonth := '03';
  221.   4 : StrMonth := '04'; 5 : StrMonth := '05'; 6 : StrMonth := '06';
  222.   7 : StrMonth := '07'; 8 : StrMonth := '08'; 9 : StrMonth := '09';
  223.  10 : StrMonth := '10'; 11 : StrMonth := '11'; 12 : StrMonth := '12';
  224.   end;
  225.   StrYear := copy(juliantoanyString,5,4);
  226.   StrDay  := copy(juliantoanyString,3,2);
  227.   AnyStr := StrMonth + StrDay + StrYear; JuliantoStr8 := AnyStr;
  228. end;
  229.  
  230. Function DayofWeek(Jdate : Integer) : Str3;
  231. begin
  232.   Case jdate MOD 7 of
  233.    0:DayofWeek:='Sun'; 1:DayofWeek:='Mon'; 2:DayofWeek := 'Tue';
  234.    3:DayofWeek:='Wed'; 4:DayofWeek:='Thu'; 5:DayofWeek := 'Fri';
  235.    6:DayofWeek:='Sat';
  236.   end;
  237. end;
  238.  
  239. Procedure DateDiff(Date1,Date2 : Integer;
  240.            Var Date_Difference : Str9);
  241. Var
  242.  Temp,Rdate1,Rdate2,Diff1 : Real;      Diff : Integer;
  243.  Return                   : String[9]; Hold : String[3];
  244. begin
  245.   Rdate2 := Date2 + 32767.5; Rdate1 := Date1 + 32767.5;
  246.   Diff1  := Rdate1 - Rdate2; Temp   := Diff1;
  247.   if Diff1 < 32 then (* determine number of Days *)
  248.   begin
  249.     Diff := Round(Diff1); Str(Diff,Hold);
  250.     Return := Hold + ' ' + 'Day';
  251.     if Diff > 1 then Return := Return + 's  ';
  252.   end;
  253.   if ((Diff1 > 31) and (Diff1 < 366)) then
  254.   begin
  255.     Diff1 := Diff1 / 30; Diff := Round(Diff1); Str(Diff,Hold);
  256.     Return := Hold + ' ' + 'Month';
  257.     if Diff > 1 then Return := Return + 's';
  258.   end;
  259.   if Diff1 > 365 then
  260.   begin
  261.     Diff1 := Diff1 / 365; Diff := Round(Diff1); Str(Diff,Hold);
  262.     Return := Hold;
  263.   end;
  264.   Date_Difference := Return; Diff := Round(Diff1);
  265. end;
  266. end.
  267.