home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TOTSRC.ZIP / TOTDATE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-02-10  |  14.6 KB  |  584 lines
  1. {               Copyright 1991 TechnoJock Software, Inc.               }
  2. {                          All Rights Reserved                         }
  3. {                         Restricted by License                        }
  4.  
  5. {                             Build # 1.00                             }
  6.  
  7. Unit totDATE;
  8. {$I TOTFLAGS.INC}
  9.  
  10. {
  11.  Development Notes:
  12.  
  13.  
  14. }
  15.  
  16. INTERFACE
  17.  
  18. Uses DOS,totLOOK,totSTR;
  19.  
  20. Type
  21.  
  22. tDate = (MMDDYY,MMDDYYYY,MMYY,MMYYYY,DDMMYY,DDMMYYYY,YYMMDD,YYYYMMDD);
  23. StrShort = string[20];
  24.  
  25. tMonths  = array[1..12] of StrShort;
  26. tDays = array[0..6] of StrShort;
  27.  
  28. pDateOBJ = ^DateOBJ;
  29. DateOBJ = object
  30.    vLastYearNextCentury: byte;
  31.    vSeparator: char;
  32.    vMonths: tMonths;
  33.    vDays: tDays;
  34.    {methods...}
  35.    constructor Init;
  36.    procedure   SetLastYearNextCentury(Yr:byte);
  37.    procedure   SetSeparator(Sep:char);
  38.    procedure   SetMonths(Mth1,Mth2,Mth3,Mth4,Mth5,Mth6,Mth7,Mth8,Mth9,Mth10,Mth11,Mth12: strshort);
  39.    procedure   SetDays(Day0,Day1,Day2,Day3,Day4,Day5,Day6:strshort);
  40.    function    GetLastYearNextCentury: byte;
  41.    function    GetSeparator: char;
  42.    function    GetMonth(Mth:byte):string;
  43.    function    GetDay(Day:byte):string;
  44.    destructor  Done;
  45. end; {DateOBJ}
  46.  
  47. function  GregtoJul(M,D,Y : longint): longint;
  48. procedure JultoGreg(Jul:longint; var M,D,Y: longint);
  49. function  Day(DStr:string;Format:tDate): word;
  50. function  Month(DStr:string;Format:tDate): word;
  51. function  Year(DStr:string;Format:tDate): word;
  52. function  StrtoJul(DStr:string;Format:tDate):longint;
  53. function  DOWStr(DStr:string;Format:tDate): byte;
  54. function  DOWJul(Jul:longint): byte;
  55. function  GregtoStr(M,D,Y:longint;Format:tDate): string;
  56. function  JultoStr(Jul:longint;Format:tDate): string;
  57. function  TodayinJul: longint;
  58. function  ValidDate(M,D,Y:longint):boolean;
  59. function  ValidDateStr(DStr:string;Format:tDate): boolean;
  60. function  StripDateStr(DStr:string;Format:tDate):string;
  61. function  FancyDateStr(Jul:longint; Long,Day:boolean): string;
  62. function  RelativeDate(DStr:string;Format:tDate;Delta:longint):string;
  63. function  StartOfYear(Jul:longint):longint;
  64. function  EndOfYear(Jul:longint):longint;
  65. function  DateFormat(Format:tDate):string;
  66. procedure DateInit;
  67.  
  68. var
  69.  
  70.   DateTOT: ^DateOBJ;
  71.  
  72. IMPLEMENTATION
  73.  
  74. {|||||||||||||||||||||||||||||||||||||||}
  75. {                                       }
  76. {     D a t e O B J   M E T H O D S     }
  77. {                                       }
  78. {|||||||||||||||||||||||||||||||||||||||}
  79. constructor DateOBJ.Init;
  80. {}
  81. begin
  82.    vLastYearNextCentury := 20;
  83.    vSeparator := '/';
  84.    SetDays('Sunday','Monday','Tuesday','Wednesday',
  85.            'Thursday','Friday','Saturday');
  86.    SetMonths('January','February','March','April','May',
  87.              'June','July','August','September',
  88.              'October','November','December');
  89. end; {DateOBJ.Init}
  90.  
  91. function DateOBJ.GetLastYearNextCentury: byte;
  92. {}
  93. begin
  94.    GetLastYearNextCentury := vLastYearNextCentury;
  95. end; {DateOBJ.GetLastYearNextCentury}
  96.  
  97. procedure DateOBJ.SetLastYearNextCentury(Yr:byte);
  98. {}
  99. begin
  100.    {$IFDEF CHECK}
  101.      if (Yr >= 0) and (Yr <= 99) then
  102.         vLastYearNextCentury := Yr;
  103.    {$ELSE}
  104.      vLastYearNextCentury := Yr;
  105.    {$ENDIF}
  106. end; {DateOBJ.GetLastYearNextCentury}
  107.  
  108. function DateOBJ.GetSeparator: char;
  109. {}
  110. begin
  111.    GetSeparator := vSeparator;
  112. end; {DateOBJ.GetSeparator}
  113.  
  114. procedure DateOBJ.SetSeparator(Sep:char);
  115. {}
  116. begin
  117.    vSeparator := Sep;
  118. end; {DateOBJ.SetSeparator}
  119.  
  120. procedure DateOBJ.SetMonths(Mth1,Mth2,Mth3,Mth4,Mth5,Mth6,Mth7,Mth8,Mth9,Mth10,Mth11,Mth12: StrShort);
  121. {}
  122. begin
  123.    vMonths[1] := Mth1;
  124.    vMonths[2] := Mth2;
  125.    vMonths[3] := Mth3;
  126.    vMonths[4] := Mth4;
  127.    vMonths[5] := Mth5;
  128.    vMonths[6] := Mth6;
  129.    vMonths[7] := Mth7;
  130.    vMonths[8] := Mth8;
  131.    vMonths[9] := Mth9;
  132.    vMonths[10] := Mth10;
  133.    vMonths[11] := Mth11;
  134.    vMonths[12] := Mth12;
  135. end; {DateOBJ.SetMonths}
  136.  
  137. procedure DateOBJ.SetDays(Day0,Day1,Day2,Day3,Day4,Day5,Day6:StrShort);
  138. {}
  139. begin
  140.    vDays[0] := Day0;
  141.    vDays[1] := Day1;
  142.    vDays[2] := Day2;
  143.    vDays[3] := Day3;
  144.    vDays[4] := Day4;
  145.    vDays[5] := Day5;
  146.    vDays[6] := Day6;
  147. end; {DateOBJ.SetDays}
  148.  
  149. function DateOBJ.GetMonth(Mth:byte):string;
  150. {}
  151. begin
  152.    if Mth in [2..12] then
  153.       GetMonth := vMonths[Mth]
  154.    else
  155.       GetMonth := vMonths[1];
  156. end; {DateOBJ.GetMonth}
  157.  
  158. function DateOBJ.GetDay(Day:byte):string;
  159. {}
  160. begin
  161.    if Day in [1..6] then
  162.       GetDay := vDays[Day]
  163.    else
  164.       GetDay := vDays[0];
  165. end; {DateOBJ.GetDay}
  166.  
  167. destructor DateOBJ.Done;
  168. begin end;
  169. {|||||||||||||||||||||||||||||||||||||||||||}
  170. {                                           }
  171. {     M i s c   P r o c   &   F u n c s     }
  172. {                                           }
  173. {|||||||||||||||||||||||||||||||||||||||||||}
  174. function PadDateStr(DStr:string;Format:tDate):string;
  175. {}
  176. var
  177.    Part1,Part2,Part3: string;
  178.    L,P: byte;
  179.    Sep1,Sep2:char;
  180.  
  181.      procedure PadOut(var S:string; width:byte);
  182.      begin
  183.         S := padright(S,width,'0');
  184.      end;
  185.  
  186. begin
  187.    if length(DStr) = length(DateFormat(Format)) then
  188.    begin
  189.       PadDateStr := DStr;
  190.       exit;
  191.    end;
  192.    P := 0;
  193.    L := length(DStr);
  194.    repeat
  195.       inc(P);
  196.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  197.    if P > L then
  198.    begin
  199.       PadDateStr := DStr;
  200.       exit;
  201.    end;
  202.    Part1 := copy(DStr,1,pred(P));
  203.    Sep1 := DStr[P];
  204.    delete(DStr,1,P);
  205.    P:= 0;
  206.    repeat
  207.       inc(P);
  208.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  209.    Part2 := copy(DStr,1,pred(P));
  210.    Sep2 := DStr[P];
  211.    Part3 := copy(DStr,succ(P),4);
  212.    case Format of
  213.       MMDDYY,YYMMDD,DDMMYY:begin
  214.           PadOut(Part1,2);
  215.           PadOut(Part2,2);
  216.           PadOut(Part3,2);
  217.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  218.       end;
  219.       MMDDYYYY,DDMMYYYY:begin
  220.           PadOut(Part1,2);
  221.           PadOut(Part2,2);
  222.           PadOut(Part3,4);
  223.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  224.       end;
  225.       YYYYMMDD:begin
  226.           PadOut(Part1,4);
  227.           PadOut(Part2,2);
  228.           PadOut(Part3,2);
  229.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  230.       end;
  231.       MMYY:begin
  232.           PadOut(Part1,2);
  233.           PadOut(Part2,2);
  234.           DStr := Part1+Sep1+Part2;
  235.       end;
  236.       MMYYYY:begin
  237.           PadOut(Part1,2);
  238.           PadOut(Part2,4);
  239.           DStr := Part1+Sep1+Part2;
  240.       end;
  241.    end; {case}
  242.    PadDateStr := DStr;
  243. end; {PadDateStr}
  244.  
  245. function GregtoJul(M,D,Y:longint):longint;
  246. {}
  247. var Factor: integer;
  248. begin
  249.    if M < 3 then
  250.       Factor := -1
  251.    else
  252.       Factor := 0;
  253.    GregtoJul :=  (1461*(Factor+4800+Y) div 4)
  254.                + ((M-2-(Factor*12))*367) div 12
  255.                - (3*((Y+4900+Factor) div 100) div 4)
  256.                + D
  257.                - 32075;
  258. end; {GregtoJul}
  259.  
  260. procedure JultoGreg(Jul:longint; var M,D,Y: longint);
  261. {}
  262. var U,V,W,X: longint;
  263. begin
  264.    inc(Jul,68569);
  265.    W := (Jul*4) div 146097;
  266.    dec(Jul,((146097*W)+3) div 4);
  267.    X := 4000*succ(Jul) div 1461001;
  268.    dec(Jul,((1461*X) div 4) - 31);
  269.    V := 80*Jul div 2447;
  270.    U := V div 11;
  271.    D := Jul - (2447*V div 80);
  272.    M := V + 2 - (U*12);
  273.    Y := X + U + (W-49)*100;
  274. end; {JultoGreg}
  275.  
  276. function Day(DStr:string;Format:tDate): word;
  277. {}
  278. var
  279.    DayStr: string;
  280. begin
  281.    DStr := PadDateStr(DStr,Format);
  282.    case Format of
  283.       MMDDYY,
  284.       MMDDYYYY: DayStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  285.       DDMMYY,
  286.       DDMMYYYY: DayStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  287.       YYMMDD:   DayStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  288.       YYYYMMDD: DayStr := NthNumber(DStr,7)+NthNumber(DStr,8);
  289.       else     DayStr := '01';
  290.    end; {case}
  291.    Day := StrToInt(DayStr);
  292. end; {Day}
  293.  
  294. function Month(DStr:string;Format:tDate): word;
  295. {}
  296. var
  297.    MonStr: string;
  298. begin
  299.    DStr := PadDateStr(DStr,Format);
  300.    case Format of
  301.       MMDDYY,
  302.       MMDDYYYY,
  303.       MMYY,
  304.       MMYYYY  :  MonStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  305.       YYMMDD,
  306.       DDMMYY,
  307.       DDMMYYYY:  MonStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  308.       YYYYMMDD:  MonStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  309.    end; {case}
  310.    Month := StrToInt(MonStr);
  311. end; {Month}
  312.  
  313. function Year(DStr:string;Format:tDate): word;
  314. {}
  315. var
  316.    YrStr: string;
  317.    TmpYr: word;
  318. begin
  319.    DStr := PadDateStr(DStr,Format);
  320.    Case Format of
  321.       MMDDYY,
  322.       DDMMYY   : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  323.       MMDDYYYY,
  324.       DDMMYYYY : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6)
  325.                           + NthNumber(DStr,7)+NthNumber(DStr,8);
  326.       MMYY     : YrStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  327.       MMYYYY   : YrStr := NthNumber(DStr,3)+NthNumber(DStr,4)
  328.                           + NthNumber(DStr,5)+NthNumber(DStr,6);
  329.       YYMMDD   : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  330.       YYYYMMDD : YrStr := NthNumber(DStr,1)+NthNumber(DStr,2)
  331.                           + NthNumber(DStr,3)+NthNumber(DStr,4);
  332.    end;
  333.    TmpYr := StrToInt(YrStr);
  334.    if (TmpYr >= 0) and (TmpYr <= 99) then
  335.    begin
  336.       if TmpYr < DateTOT^.GetLastYearNextCentury then
  337.          TmpYr := 2000 + TmpYr
  338.       else
  339.          TmpYr := 1900 + TmpYr;
  340.    end;
  341.    Year := TmpYr;
  342. end; {Year}
  343.  
  344. function GregtoStr(M,D,Y:longint;Format:tDate): string;
  345. {}
  346. var
  347.    PadChar : char;
  348.    DD,MM: string[2];
  349.    YY: string[4];
  350. begin
  351.    PadChar := DateTOT^.GetSeparator;
  352.    DD := InttoStr(D);
  353.    if D < 10 then
  354.       DD := '0'+DD;
  355.    MM := InttoStr(M);
  356.    if M < 10 then
  357.       MM := '0'+MM;
  358.    if (Format in [MMDDYY,MMYY,DDMMYY,YYMMDD])
  359.    and ((Y > 99) or (Y < -99)) then
  360.       Y := Y Mod 100;
  361.    YY := InttoStr(Y);
  362.    if Y < 10 then
  363.       YY := '0'+YY;
  364.    Case Format of
  365.       MMDDYY,
  366.       MMDDYYYY: GregtoStr := MM+PadChar+DD+Padchar+YY;
  367.       MMYY,
  368.       MMYYYY  : GregtoStr := MM+Padchar+YY;
  369.       DDMMYY,
  370.       DDMMYYYY: GregtoStr := DD+PadChar+MM+Padchar+YY;
  371.       YYMMDD,
  372.       YYYYMMDD: GregtoStr := YY+PadChar+MM+Padchar+DD;
  373.    end; {case}
  374. end; {GregtoStr}
  375.  
  376. function JultoStr(Jul:longint;Format:tDate): string;
  377. {}
  378. var M,D,Y:longint;
  379. begin
  380.    JultoGreg(Jul,M,D,Y);
  381.    JultoStr := GregtoStr(M,D,Y,Format);
  382. end; {JultoStr}
  383.  
  384. function TodayinJul: longint;
  385. {}
  386. var 
  387.  M,D,Y,DOW: word;
  388. begin
  389.    GetDate(Y,M,D,DOW);
  390.    TodayinJul := GregtoJul(M,D,Y);
  391. end; {TodayinJul}
  392.  
  393. function ValidDate(M,D,Y:longint):boolean;
  394. {}
  395. begin
  396.    if (D < 1)
  397.    or (D > 31)
  398.    or (M < 1)
  399.    or (M > 12)
  400.    then 
  401.       ValidDate := False
  402.    else
  403.       Case M of
  404.          4,6,9,11: ValidDate := (D <= 30);
  405.          2:        ValidDate := (D <= 28)
  406.                                 or ( (D = 29)
  407.                                      and (Y <> 1900) 
  408.                                      and (Y <> 0)
  409.                                      and (Y mod 4 = 0)
  410.                                     );
  411.           else ValidDate := true;
  412.       end; {case}
  413. end; {ValidDate}
  414.  
  415. function  ValidDateStr(DStr:string;Format:tDate): boolean;
  416. {}
  417. var
  418.  M,D,Y: word;
  419. begin
  420.    M := Month(DStr,Format);
  421.    D := Day(DStr,Format);
  422.    Y := Year(DStr,Format);
  423.    ValidDateStr := ValidDate(M,D,Y);
  424. end; {ValidDateStr}
  425.  
  426. function DOWJul(Jul:longint): byte;
  427. var M,D,Y,N: longint;
  428. begin
  429.    JultoGreg(Jul,M,D,Y);
  430.    if M <=2 then
  431.      N := 1461 * (Y-1) div 4 + 153 * (M+13) div 5 + D
  432.    else
  433.      N := 1461 * Y div 4 + 153 * (M+1) div 5 + D;
  434.    N:= abs((N - 621049)) mod 7;
  435.    DOWJul := N;
  436. end; {DayOfWeek}
  437.  
  438. function StrtoJul(DStr:string;Format:tDate):longint;
  439. {}
  440. var
  441.   M,D,Y:longint;
  442. begin
  443.    M := Month(Dstr,Format);
  444.    D := Day(Dstr,Format);
  445.    Y := Year(Dstr,Format);
  446.    StrtoJul := GregtoJul(M,D,Y);
  447. end; {StrtoJul}
  448.  
  449. function DOWStr(DStr:string;Format:tDate): byte;
  450. {}
  451. begin
  452.    DOWStr := DOWJul(StrtoJul(Dstr,Format));
  453. end; {DOWStr}
  454.  
  455. function StripDateStr(DStr:string;Format:tDate):string;
  456. {}
  457. begin
  458.    case Format of
  459.       MMDDYY,
  460.       MMDDYYYY,
  461.       DDMMYY,
  462.       DDMMYYYY,
  463.       YYMMDD: begin
  464.                  delete(Dstr,3,1);
  465.                  delete(Dstr,5,1);
  466.               end;
  467.       MMYY,
  468.       MMYYYY  : delete(DStr,3,1);
  469.       YYYYMMDD: begin
  470.                   delete(DStr,5,1);
  471.                   delete(DStr,7,1);
  472.                 end;
  473.    end; {case}
  474.    StripDateStr := DStr;
  475. end; {StripDateStr}
  476.  
  477. function FancyDateStr(Jul:longint; Long,Day:boolean): string;
  478. {}
  479. var 
  480.   M,D,Y:longint;
  481.   TheDay: byte;
  482.   Str: string;
  483. begin
  484.    JultoGreg(Jul,M,D,Y);
  485.    Str := ' '+InttoStr(D)+', '+IntToStr(Y);
  486.    if Long then
  487.       Str := dateTOT^.GetMonth(M) + Str
  488.    else
  489.       Str := copy(dateTOT^.GetMonth(M),1,3) + Str;
  490.    if Day then
  491.    begin
  492.       TheDay := DOWJul(Jul);
  493.       if Long then
  494.          Str := dateTOT^.GetDay(TheDay) + ' ' + Str
  495.       else
  496.          Str := copy(dateTOT^.GetDay(TheDay),1,3) + ' ' + Str;
  497.    end;
  498.    FancyDateStr := Str;
  499. end; {FancyDateStr}
  500.  
  501. function RelativeDate(DStr:string;Format:tDate;Delta:longint):string;
  502. {}
  503. begin
  504.    RelativeDate := JultoStr(StrtoJul(DStr,Format)+Delta,Format);
  505. end; {RelativeDate}
  506.  
  507. function EndOfMonth(Jul:longint):longint;
  508. {}
  509. var M,D,Y:longint;
  510. begin
  511.    JultoGreg(Jul,M,D,Y);
  512.    case M of
  513.       4,6,9,11: D := 30;
  514.       2: if (Y mod 4 = 0) and (Y <> 0) and (Y <> 1900) then
  515.             D := 29
  516.          else
  517.             D := 28;
  518.       else D := 31;
  519.    end; {case}
  520.    EndOfMonth := GregtoJul(M,D,Y);
  521. end; {EndOfMonth}
  522.  
  523. function StartOfMonth(Jul:longint):longint;
  524. {}
  525. var M,D,Y:longint;
  526. begin
  527.    JultoGreg(Jul,M,D,Y);
  528.    StartOfMonth := GregtoJul(M,1,Y);
  529. end; {StartOfMonth}
  530.  
  531. function StartOfYear(Jul:longint):longint;
  532. {}
  533. var M,D,Y:longint;
  534. begin
  535.    JultoGreg(Jul,M,D,Y);
  536.    StartOfYear := GregtoJul(1,1,Y);
  537. end; {StartOfYear}
  538.  
  539. function EndOfYear(Jul:longint):longint;
  540. {}
  541. var M,D,Y:longint;
  542. begin
  543.    JultoGreg(Jul,M,D,Y);
  544.    EndOfYear := GregtoJul(12,31,Y);
  545. end; {EndOfYear}
  546.  
  547. function DateFormat(Format:tDate):string;
  548. {}
  549. var Sep:char;
  550. begin
  551.    Sep := DateTOT^.GetSeparator;
  552.    Case Format of
  553.       MMDDYY: DateFormat := 'MM'+Sep+'DD'+Sep+'YY';
  554.       MMDDYYYY: DateFormat := 'MM'+Sep+'DD'+Sep+'YYYY';
  555.       MMYY: DateFormat := 'MM'+Sep+'YY';
  556.       MMYYYY: DateFormat := 'MM'+Sep+'YYYY';
  557.       DDMMYY: DateFormat := 'YY'+Sep+'MM'+Sep+'YY';
  558.       DDMMYYYY: DateFormat := 'DD'+Sep+'MM'+Sep+'YYYY';
  559.       YYMMDD: DateFormat := 'YY'+Sep+'MM'+Sep+'DD';
  560.       YYYYMMDD: DateFormat :=  'YYYYY'+Sep+'MM'+Sep+'DD';
  561.    end; {case}
  562. end; {DateFormat}
  563. {|||||||||||||||||||||||||||||||||||||||||||||||}
  564. {                                               }
  565. {     U N I T   I N I T I A L I Z A T I O N     }
  566. {                                               }
  567. {|||||||||||||||||||||||||||||||||||||||||||||||}
  568.  
  569. procedure DateInit;
  570. {initilizes objects and global variables}
  571. begin
  572.    new(DateTOT,Init);
  573. end; {DateInit}
  574.  
  575. {end of unit - add initialization routines below}
  576. {$IFNDEF OVERLAY}
  577. begin
  578.    DateInit;
  579. {$ENDIF}
  580. end.
  581.  
  582.  
  583.  
  584.