[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    unit JDates;

    { A unit providing Julian day numbers and date manipulations.

      NOTE:
       The range of Dates this unit will handle is 1/1/1900 to 1/1/2078

      Version 1.00 - 10/26/1987 - First general release

      Scott Bussinger
      Professional Practice Systems
      110 South 131st Street
      Tacoma, WA  98444
      (206)531-8944
      Compuserve 72247,2671

      Version 1.01 - 10/09/1995 - Updated for use with Delphi v1.0
                       Lets see some other code last this long without change

      Dennis Passmore
      1929 Mango Tree Drive
      Edgewater Fl, 32141

      Compuserve 71240,2464 }

    interface
    uses
      Sysutils;

    const
      BlankDate = $FFFF;                         { Constant for Not-a-real-Date }

    type TDate = Word;
         TDay = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);
         TDaySet = set of TDay;

    procedure GetDate(var Year,Month,Day,Wday: Word);
      { replacement for old WINDOS proc }

    procedure GetTime(var Hour,Min,Sec,MSec: Word);
      { replacement for old WINDOS proc }

    function  CurrentJDate: Tdate;

    function  ValidDate(Day,Month,Year: Word): boolean;
      { Check if the day,month,year is a real date storable in a Date variable }

    procedure DMYtoDate(Day,Month,Year: Word;var Julian: TDate);
      { Convert from day,month,year to a date }

    procedure DateToDMY(Julian: TDate;var Day,Month,Year: Word);
      { Convert from a date to day,month,year }

    function BumpDate(Julian: TDate;Days,Months,Years: Integer): TDate;
      { Add (or subtract) the number of days, months, and years to a date }

    function DayOfWeek(Julian: TDate): TDay;
      { Return the day of the week for the date }

    function DayString(WeekDay: TDay): string;
      { Return a string version of a day of the week }

    function MonthString(Month: Word): string;
      { Return a string version of a month }

    function DateToStr(Julian: TDate): string;
      { Convert a date to a sortable string }

    function StrToDate(StrVar: string): TDate;
      { Convert a sortable string form to a date }

    implementation

    procedure GetDate(var Year,Month,Day,Wday: Word);
    var
      td: TDatetime;
    begin
      td := Date;

      DeCodeDate(td,Year,Month,Day);
      Wday := sysutils.DayofWeek(td);
    end;

    procedure GetTime(var Hour,Min,Sec,MSec: Word);
    var
      td: TDatetime;
    begin
      td := Now;
      DecodeTime(td,Hour,Min,Sec,MSec);
    end;

    function  CurrentJdate: Tdate;
    var
     y,m,d,w: word;
     jd: TDate;
    begin
      GetDate(y,m,d,w);
      DMYtoDate(d,m,y,jd);
      CurrentJDate:= jd;
    end;

    function ValidDate(Day,Month,Year: Word): boolean;
      { Check if the day,month,year is a real date storable in a Date variable }
    begin
      if {(Day<1) or }(Year<1900) or (Year>2078) then
        ValidDate := false
      else
        case Month of
          1,3,5,7,8,10,12: ValidDate := Day <= 31;

          4,6,9,11: ValidDate := Day <= 30;
          2: ValidDate := Day <= 28 + ord((Year mod 4)=0)*ord(Year<>1900)
          else ValidDate := false
        end
    end;

    procedure DMYtoDate(Day,Month,Year: Word;var Julian: TDate);
      { Convert from day,month,year to a date }
      { Stored as number of days since January 1, 1900 }
      { Note that no error checking takes place in this routine -- use ValidDate }
    begin
    if (Year=1900) and (Month<3) then
      if Month = 1 then
        Julian := pred(Day)
      else
        Julian := Day + 30
    else
      begin
        if Month > 2 then
          dec(Month,3)
        else
          begin
            inc(Month,9);
            dec(Year)

          end;
        dec(Year,1900);
        Julian := (1461*longint(Year) div 4) + ((153*Month+2) div 5) + Day + 58;
      end
    end;

    procedure DateToDMY(Julian: TDate;var Day,Month,Year: Word);
      { Convert from a date to day,month,year }
    var
      LongTemp: longint;
          Temp: Word;
    begin
      if Julian <= 58 then
        begin
          Year := 1900;
          if Julian <= 30 then
            begin
              Month := 1;
              Day := succ(Julian)
            end
          else
            begin
              Month := 2;
              Day := Julian - 30
            end
        end
      else
        begin
          LongTemp := 4*longint(Julian) - 233;

          Year := LongTemp div 1461;
          Temp := LongTemp mod 1461 div 4 * 5 + 2;
          Month := Temp div 153;
          Day := Temp mod 153 div 5 + 1;
          inc(Year,1900);
          if Month < 10 then
            inc(Month,3)
          else
            begin
              dec(Month,9);
              inc(Year)
            end
        end
    end;

    function BumpDate(Julian: TDate;Days,Months,Years: Integer): TDate;
      { Add (or subtract) the number of days, months, and years to a date }
      { Note that months and years are added first before days }
      { Note further that there are no overflow/underflow checks }
    var Day: Word;
        Month: Word;
        Year: Word;
    begin
      DateToDMY(Julian,Day,Month,Year);

      Month := Month + Months - 1;
      Year := Year + Years + (Month div 12) - ord(Month<0);
      Month := (Month + 12000) mod 12 + 1;
      DMYtoDate(Day,Month,Year,Julian);
      BumpDate := Julian + Days
    end;

    function DayOfWeek(Julian: TDate): TDay;
      { Return the day of the week for the date }
    begin
      DayOfWeek := TDay(succ(Julian) mod 7)
    end;

    function DayString(WeekDay: TDay): string;
      { Return a string version of a day of the week }
    const DayStr: array[Sunday..Saturday] of string[9] =
         ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');

    begin
      DayString := DayStr[WeekDay]
    end;

    function MonthString(Month: Word): string;
      { Return a string version of a month }
      const MonthStr: array[1..12] of string[9] =
         ('January','February','March','April','May','June','July','August',
                                     'September','October','November','December');
    begin
      MonthString := MonthStr[Month]
    end;

    function DateToStr(Julian: TDate): string;
      { Convert a date to a sortable string - NOT displayable }
    const tResult: record
                    case integer of
                      0: (Len: byte;  W: word);
                      1: (Str: string[2])

                    end = (Str:'  ');
    begin
      tResult.W := swap(Julian);
      DateToStr := tResult.Str
    end;

    function StrToDate(StrVar: string): TDate;
      { Convert a sortable string form to a date }
    var Temp: record
                Len: byte;
                  W: word
              end absolute StrVar;
    begin
      StrToDate := swap(Temp.W)
    end;

    end.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]