home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPDB311.ZIP / TPDBDATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-02-14  |  8.0 KB  |  312 lines
  1. Unit TPDBDate;
  2.  
  3.                        (*****************************)
  4.                        (*        TPDBDATE.tpu       *)
  5.                        (*     TPDB Version 2.2      *)
  6.                        (*        March 2,1989       *)
  7.                        (*   Time and Date Routines  *)
  8.                        (*       for TPDB.tpu        *)
  9.                        (*  Public Domain Source by  *)
  10.                        (*        Brian Corll        *)
  11.                        (*****************************)
  12.                        (*   Credits: John Wood and  *)
  13.                        (*       Scott Bussinger     *)
  14.                        (*****************************)
  15.  
  16. INTERFACE
  17.  
  18. Uses Dos;
  19.  
  20. Type
  21.     DayStr   = String[9];
  22.     DateType = word;
  23.     DateStr  = String[8];
  24.     TimeStr  = String[13];
  25.     Str9     = String[9];
  26.  
  27. Function CalcDate(InDate:DateStr;Days,Months,Years: integer): DateStr;
  28. (* Add or subtract days,months, or years from two dates. *)
  29.  
  30. Function CDOW(InDate : DateStr): DayStr;
  31. (* Returns character day of week - i.e. 'Monday','Tuesday',etc. *)
  32.  
  33. Function CMonth(InDate : DateStr) : Str9;
  34. (* Returns character month - i.e. 'March' *)
  35.  
  36. Function CompDates(Date1,Date2 : DateStr):Word;
  37. (* Compares two dates and calculates the number of days between them. *)
  38.  
  39. Function CTOD(InDate: DateStr) : DateType;
  40. (* Converts a .DBF compatible date field to a word date type. *)
  41.  
  42. Function DTOC(Julian: DateType) : DateStr;
  43. (* Converts a word date type to a string compatible with .DBF date fields. *)
  44.  
  45.  
  46. Function Mon(InDate : DateStr) : Byte;
  47. (* Returns numeric value for the month in a date. *)
  48.  
  49. Function TimeNow : TimeStr;
  50. (* Returns current time in formatted string. *)
  51.  
  52. Function Today : DateStr;
  53. (* Returns current date in .DBF date field compatible format. *)
  54.  
  55. Function ValidDate(InDate : DateStr): boolean;
  56. (* Checks whether a date is valid. *)
  57.  
  58. Function FormDate(InDate:DateStr) : String;
  59. (* Formats a date as 'MM/DD/YY' *)
  60.  
  61.  
  62.  
  63.  
  64. IMPLEMENTATION
  65.  
  66. Const
  67.      Months : Array[1..12] of Str9 = ('January  ','February ','March    ',
  68.           'April    ','May      ','June     ','July     ',
  69.          'August   ','September','October  ','November ','December ');
  70.  
  71. Var
  72.    Temp,Month,Day,Year,ErrCode : Integer;
  73.    MM,DD : String[2];
  74.    YY : String[4];
  75.  
  76.  
  77. Function CDOW(InDate : DateStr) : DayStr;
  78. (* Returns the name of the day of the week represented by
  79.    a date. *)
  80.  
  81. Var
  82.    DayOfWeek,DOW        : Integer;
  83.  
  84. begin
  85.      YY := Copy(InDate,1,4); MM := Copy(InDate,5,2); DD := Copy(InDate,7,2);
  86.      Val(MM,Month,ErrCode); Val(DD,Day,ErrCode); Val(YY,Year,ErrCode);
  87.      If month<=2 then
  88.         begin
  89.         month := month + 12;
  90.         year := year -1;
  91.         end;
  92.  
  93.      DayOfWeek := (Day+month*2+(month+1)*6 div 10 +year + year div 4 - year
  94.             div 100 + year div 400 + 2) mod 7;
  95.  
  96.      If DayOfWeek = 0 then DOW := 7
  97.         else DOW := DayOfWeek;
  98.  
  99.      Case DOW of
  100.           1 : CDOW := 'Sunday';
  101.           2 : CDOW := 'Monday';
  102.           3 : CDOW := 'Tuesday';
  103.           4 : CDOW := 'Wednesday';
  104.           5 : CDOW := 'Thursday';
  105.           6 : CDOW := 'Friday';
  106.           7 : CDOW := 'Saturday';
  107.      end;
  108. end;
  109.  
  110. Function CTOD(InDate: DateStr) : DateType;
  111. (* Convert from a date string to a word date type. *)
  112. Var
  113.    Julian : DateType;
  114.  
  115. begin
  116.      YY := Copy(InDate,1,4);
  117.      MM := Copy(InDate,5,2);
  118.      DD := Copy(InDate,7,2);
  119.  
  120.      Val(YY,Year,ErrCode);
  121.      Val(MM,Month,ErrCode);
  122.      Val(DD,Day,ErrCode);
  123.  
  124.      If (Year=1900) and (Month<3) then
  125.      if Month = 1 then
  126.       Julian := pred(Day)
  127.      else
  128.       Julian := Day + 30
  129.    else
  130.     begin
  131.     if Month > 2
  132.      then
  133.       dec(Month,3)
  134.      else
  135.       begin
  136.       inc(Month,9);
  137.       dec(Year)
  138.       end;
  139.     dec(Year,1900);
  140.     Julian := (1461*longint(Year) div 4) + ((153*Month+2) div 5) + Day + 58
  141.     end;
  142.     CTOD := Julian;
  143.   end;
  144.  
  145. Function DTOC(Julian: DateType) : DateStr;
  146. (* Convert from a word date type to a date string. *)
  147. Var
  148.    LongTemp: longint;
  149.  
  150. begin
  151.   if Julian <= 58
  152.    then
  153.     begin
  154.     Year := 1900;
  155.     if Julian <= 30
  156.      then
  157.       begin
  158.       Month := 1;
  159.       Day := succ(Julian)
  160.       end
  161.      else
  162.       begin
  163.       Month := 2;
  164.       Day := Julian - 30
  165.       end
  166.     end
  167.    else
  168.     begin
  169.     LongTemp := 4*longint(Julian) - 233;
  170.     Year := LongTemp div 1461;    Temp := LongTemp mod 1461 div 4 * 5 + 2;
  171.     Month := Temp div 153;
  172.     Day := Temp mod 153 div 5 + 1;
  173.     inc(Year,1900);
  174.     if Month < 10
  175.      then
  176.       inc(Month,3)
  177.      else
  178.       begin
  179.       dec(Month,9);
  180.       inc(Year)
  181.       end
  182.     end;
  183.     Str(Month : 2,MM);
  184.     Str(Day : 2,DD);
  185.     Str(Year : 4,YY);
  186.     If Month<10 then MM := '0'+Copy(MM,2,1);
  187.     If Day<10 then DD := '0'+Copy(DD,2,1);;
  188.     DTOC := YY+MM+DD;
  189.   end;
  190.  
  191. Function ValidDate(InDate : DateStr): boolean;
  192. (* Check whether a date field contains a valid date. *)
  193. begin
  194.      YY := Copy(InDate,1,4); MM := Copy(InDate,5,2); DD := Copy(InDate,7,2);
  195.      Val(DD,Day,ErrCode); Val(MM,Month,ErrCode); Val(YY,Year,ErrCode);
  196.      If (Day=0) and (Year-1900=0) and(Month=0) then
  197.      begin
  198.           ValidDate := True;
  199.           Exit;
  200.      end;
  201.      If (Day<1) or (Year<1900) or (Year>2078) then
  202.      ValidDate := false
  203.      else
  204.      Case Month of
  205.       1,3,5,7,8,10,12 : ValidDate := Day <= 31;
  206.       4,6,9,11        : ValidDate := Day <= 30;
  207.       2: ValidDate    := Day <= 28 + ord((Year mod 4)=0)*ord(Year<>1900)
  208.       else ValidDate  := false
  209.       end
  210.   end;
  211.  
  212. Function CalcDate(InDate:DateStr;Days,Months,Years: integer): DateStr;
  213. (* Add or subtract days, months , and years from a specific date string,
  214.  as stored in a .DBF record. *)
  215. Var
  216.    Julian : DateType;
  217.    TempDate   : DateStr;
  218.   begin
  219.   YY := Copy(InDate,1,4);
  220.   MM := Copy(InDate,5,2);
  221.   DD := Copy(InDate,7,2);
  222.   Val(MM,Month,ErrCode);
  223.   Val(DD,Day,errCode);
  224.   Val(YY,Year,ErrCode);
  225.   Month := Month + Months - 1;
  226.   Year := Year + Years + (Month div 12) - ord(Month<0);
  227.   Month := (Month + 12000) mod 12 + 1;
  228.   Str(Month : 2,MM);
  229.   Str(Day : 2,DD);
  230.   Str(Year : 4,YY);
  231.   If Month<10 then MM := '0'+Copy(MM,2,1);
  232.   If Day<10 then DD := '0'+Copy(DD,2,1);
  233.   TempDate := YY+MM+DD;
  234.   Julian := CTOD(TempDate)+Days;
  235.   CalcDate := DTOC(Julian);
  236.   end;
  237.  
  238. Function CompDates(Date1,Date2 : DateStr):Word;
  239. (* Compare two dates and calculate the number of
  240.  days between them. *)
  241. Begin
  242.   If CTOD(Date1)>CTOD(Date2) then
  243.      CompDates := CTOD(Date1)-CTOD(Date2)
  244.   else
  245.      CompDates := CTOD(Date2)-CTOD(Date1);
  246. End;
  247.  
  248. Function CMonth(InDate : DateStr) : Str9;
  249. (* Returns the month name for any date. *)
  250.  
  251. begin
  252.      MM := Copy(InDate,5,2);
  253.      Val(MM,Month,ErrCode);
  254.      CMonth := Months[Month]
  255. end;
  256.  
  257. Function TimeNow : TimeStr;
  258. (* Returns a formatted string for the current time. *)
  259. Var
  260.    Hour,Minute,Second,Sec100 : Word;
  261.    HH,MM,SS : String[2];
  262.    Temp : String[8];
  263.    Code : Integer;
  264. begin
  265.      GetTime(Hour,Minute,Second,Sec100);
  266.      Str(Minute,MM);
  267.      Str(Second,SS);
  268.      If Minute<10 then MM := '0'+MM;
  269.      If Second<10 then SS := '0'+SS;
  270.      If Hour>12 then
  271.      begin
  272.           Str(Hour-12,HH);
  273.      end
  274.      else Str(Hour,HH);
  275.      If Hour>=12 then TimeNow := HH+':'+MM+':'+SS+' p.m.'
  276.      else TimeNow := HH+':'+MM+':'+SS+' a.m.';
  277. end;
  278.  
  279. Function Today : DateStr;
  280. (* Returns today's date in dBASE III date format. *)
  281. Var
  282.   mMonth, mDay, mYear, mDayOfWk : Word;
  283. Begin
  284.   GetDate(mYear,mMonth,mDay,mDayOfWk);
  285.   Str(mMonth,MM);
  286.   Str(mDay,DD);
  287.   Str(mYear,YY);
  288.   If mMonth<10 Then insert('0',MM,1);
  289.   If mDay  <10 Then insert('0',DD,1);
  290.   Today := YY+MM+DD;
  291. End;
  292.  
  293. Function Mon(InDate : DateStr) : Byte;
  294. (* Returns number of month in a date. *)
  295. Var
  296.    Temp : Byte;
  297. begin
  298.      MM := Copy(InDate,5,2);
  299.      Val(MM,Temp,ErrCode);
  300.      Mon := Temp;
  301. end;
  302.  
  303. Function FormDate(InDate:DateStr):String;
  304. (* Formats dBASE date field as MM/DD/YY *)
  305. Var
  306.     OutDate : String[8];
  307. begin
  308.     OutDate := Copy(InDate,5,2)+'/'+Copy(InDate,7,2)+'/'+Copy(InDate,3,2);
  309.     FormDate := OutDate;
  310. end;
  311.  
  312. END. (* TPDBDate *)