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