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

    Unit TCDate;

      { Author: Trevor J Carlsen  Released into the public domain }
      {         PO Box 568                                        }
      {         Port Hedland                                      }
      {         Western Australia 6721                            }
      {         Voice +61 91 732 026                              }

    Interface

    Uses Dos;

    Type
      Date          = Word;
      UnixTimeStamp = LongInt;

    Const
      WeekDays   : Array[0..6] of String[9] =
                   ('Sunday','Monday','Tuesday','Wednesday','Thursday',
                    'Friday','Saturday');
      months     : Array[1..12] of String[9] =
                   ('January','February','March','April','May','June','July',
                    'August','September','October','November','December');

    Function DayofTheWeek(pd : date): Byte;
     { Returns the day of the week For any date  Sunday = 0 .. Sat = 6    }
     { pd = a packed date as returned by the Function PackedDate          }
     { eg...  Writeln('today is ',WeekDays[DayofTheWeek(today))];         }

    Function PackedDate(yr,mth,d: Word): date;
     { Packs a date into a Word which represents the number of days since }
     { Dec 31,1899   01-01-1900 = 1                                       }

    Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp;
     { Packs a date and time into a four Byte unix style Variable which   }
     { represents the number of seconds that have elapsed since midnight  }
     { on Jan 1st 1970.                                                   }

    Procedure UnPackDate(Var yr,mth,d: Word; pd : date);
     { Unpacks a Word returned by the Function PackedDate into its        }
     { respective parts of year, month and day                            }

    Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp);
     { Unpacks a UnixTimeStamp Variable into its Component parts.         }

    Function DateStr(pd: date; Format: Byte): String;
     { Unpacks a Word returned by the Function PackedDate into its        }
     { respective parts of year, month and day and then returns a String  }
     { Formatted according to the specifications required.                }
     { if the Format is > 9 then the day of the week is prefixed to the   }
     { returned String.                                                   }
     { Formats supported are:                                             }
     {     0:  dd/mm/yy                                                   }
     {     1:  mm/dd/yy                                                   }
     {     2:  dd/mm/yyyy                                                 }
     {     3:  mm/dd/yyyy                                                 }
     {     4:  [d]d xxx yyyy   (xxx is alpha month of 3 Chars)            }
     {     5:  xxx [d]d, yyyy                                             }
     {     6:  [d]d FullAlphaMth yyyy                                     }
     {     7:  FullAlphaMth [d]d, yyyy                                    }
     {     8:  [d]d-xxx-yy                                                }
     {     9:  xxx [d]d, 'yy                                              }

    Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean;
     { Validates the date and time data to ensure no out of range errors  }
     { can occur and returns an error code to the calling Procedure. A    }
     { errorcode of zero is returned if no invalid parameter is detected. }
     { Errorcodes are as follows:                                         }

     {   Year out of range (< 1901 or > 2078) bit 0 of errorcode is set.  }
     {   Month < 1 or > 12                    bit 1 of errorcode is set.  }
     {   Day < 1 or > 31                      bit 2 of errorcode is set.  }
     {   Day out of range For month           bit 2 of errorcode is set.  }

    Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte);
     { Parses a date String in several Formats into its Component parts   }
     { It is the Programmer's responsibility to ensure that the String    }
     { being parsed is a valid date String in the Format expected.        }
     { Formats supported are:                                             }
     {     0:  dd/mm/yy[yy]                                               }
     {     1:  mm/dd/yy[yy]                                               }

    Function NumbofDaysInMth(y,m : Word): Byte;
     { returns the number of days in any month                            }

    Function IncrMonth(pd: date; n: Word): date;
     { Increments pd by n months.                                         }

    Function today : date;
     { returns the number of days since 01-01-1900                        }

    Function ordDate (Y,M,D : Word):LongInt; { returns ordinal Date yyddd }

    Function Dateord (S : String) : String;    { returns Date as 'yymmdd' }

    {============================================================================= }

    Implementation

     Const
      TDays       : Array[Boolean,0..12] of Word =
                    ((0,31,59,90,120,151,181,212,243,273,304,334,365),
                    (0,31,60,91,121,152,182,213,244,274,305,335,366));
      UnixDatum   = LongInt(25568);
      SecsPerDay  = 86400;
      SecsPerHour = LongInt(3600);
      SecsPerMin  = LongInt(60);
      MinsPerHour = 60;

    Function DayofTheWeek(pd : date): Byte;
      begin
        DayofTheWeek := pd mod 7;
      end; { DayofTheWeek }

    Function PackedDate(yr,mth,d : Word): date;
      { valid For all years 1901 to 2078                                  }
      Var
        temp  : Word;
        lyr   : Boolean;
      begin
        lyr   := (yr mod 4 = 0);
        if yr >= 1900 then
          dec(yr,1900);
        temp  := yr * Word(365) + (yr div 4) - ord(lyr);
        inc(temp,TDays[lyr][mth-1]);
        inc(temp,d);
        PackedDate := temp;
      end;  { PackedDate }

    Function UnixTime(yr,mth,d,hr,min,sec: Word): UnixTimeStamp;
      { Returns the number of seconds since 00:00 01/01/1970 }
      begin
        UnixTime := SecsPerDay * (PackedDate(yr,mth,d) - UnixDatum) +
                    SecsPerHour * hr + SecsPerMin * min + sec;
      end;  { UnixTime }

    Procedure UnPackDate(Var yr,mth,d: Word; pd : date);
      { valid For all years 1901 to 2078                                  }
      Var
        julian : Word;
        lyr    : Boolean;
      begin
        d      := pd;
        yr     := (LongInt(d) * 4) div 1461;
        julian := d - (yr * 365 + (yr div 4));
        inc(yr,1900);
        lyr    := (yr mod 4 = 0);
        inc(julian,ord(lyr));
        mth    := 0;
        While julian > TDays[lyr][mth] do
          inc(mth);
        d      := julian - TDays[lyr][mth-1];
      end; { UnPackDate }

    Procedure UnPackUnix(Var yr,mth,d,hr,min,sec: Word; uts: UnixTimeStamp);
      Var
        temp : UnixTimeStamp;
      begin
        UnPackDate(yr,mth,d,date(uts div SecsPerDay) + UnixDatum);
        temp   := uts mod SecsPerDay;
        hr     := temp div SecsPerHour;
        min    := (temp mod SecsPerHour) div MinsPerHour;
        sec    := temp mod SecsPerMin;
      end;  { UnPackUnix }

    Function DateStr(pd: date; Format: Byte): String;

      Var
        y,m,d    : Word;
        YrStr    : String[5];
        MthStr   : String[11];
        DayStr   : String[8];
        TempStr  : String[5];
      begin
        UnpackDate(y,m,d,pd);
        str(y,YrStr);
        str(m,MthStr);
        str(d,DayStr);
        TempStr := '';
        if Format > 9 then
          TempStr := copy(WeekDays[DayofTheWeek(pd)],1,3) + ' ';
        if (Format mod 10) < 4 then begin
          if m < 10 then
            MthStr := '0'+MthStr;
          if d < 10 then
            DayStr := '0'+DayStr;
        end;
        Case Format mod 10 of  { Force Format to a valid value }
          0: DateStr := TempStr+DayStr+'/'+MthStr+'/'+copy(YrStr,3,2);
          1: DateStr := TempStr+MthStr+'/'+DayStr+'/'+copy(YrStr,3,2);
          2: DateStr := TempStr+DayStr+'/'+MthStr+'/'+YrStr;
          3: DateStr := TempStr+MthStr+'/'+DayStr+'/'+YrStr;
          4: DateStr := TempStr+DayStr+' '+copy(months[m],1,3)+' '+YrStr;
          5: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+' '+YrStr;
          6: DateStr := TempStr+DayStr+' '+months[m]+' '+YrStr;
          7: DateStr := TempStr+months[m]+' '+DayStr+' '+YrStr;
          8: DateStr := TempStr+DayStr+'-'+copy(months[m],1,3)+'-'+copy(YrStr,3,2);
          9: DateStr := TempStr+copy(months[m],1,3)+' '+DayStr+', '''+copy(YrStr,3,2);
        end;  { Case }
      end;  { DateStr }

    Function ValidDate(yr,mth,d : Word; Var errorcode : Byte): Boolean;
      begin
        errorcode := 0;
        if (yr < 1901) or (yr > 2078) then
          errorcode := (errorcode or 1);
        if (d < 1) or (d > 31) then
          errorcode := (errorcode or 2);
        if (mth < 1) or (mth > 12) then
          errorcode := (errorcode or 4);
        Case mth of
          4,6,9,11: if d > 30 then errorcode := (errorcode or 2);
                 2: if d > (28 + ord((yr mod 4) = 0)) then
                      errorcode := (errorcode or 2);
          end; {Case }
        ValidDate := (errorcode = 0);
        if errorcode <> 0 then Write(#7);
      end; { ValidDate }

    Procedure ParseDateString(Var dstr; Var y,m,d : Word; Format : Byte);
      Var
        left,middle       : Word;
        errcode           : Integer;
        st                : String Absolute dstr;
      begin
        val(copy(st,1,2),left,errcode);
        val(copy(st,4,2),middle,errcode);
        val(copy(st,7,4),y,errcode);
        Case Format of
          0: begin
               d := left;
               m := middle;
             end;
          1: begin
               d := middle;
               m := left;
             end;
        end; { Case }
      end; { ParseDateString }

    Function NumbofDaysInMth(y,m : Word): Byte;
      { valid For the years 1901 - 2078                                   }
      begin
        Case m of
          1,3,5,7,8,10,12: NumbofDaysInMth := 31;
          4,6,9,11       : NumbofDaysInMth := 30;
          2              : NumbofDaysInMth := 28 +
                           ord((y mod 4) = 0);
        end;
      end; { NumbofDaysInMth }

    Function IncrMonth(pd: date; n: Word): date;
      Var y,m,d : Word;
      begin
        UnpackDate(y,m,d,pd);
        dec(m);
        inc(m,n);
        inc(y,m div 12); { if necessary increment year }
        m := succ(m mod 12);
        if d > NumbofDaysInMth(y,m) then
          d := NumbofDaysInMth(y,m);
        IncrMonth := PackedDate(y,m,d);
      end;  { IncrMonth }

    Function today : date;
      Var y,m,d,dw : Word;
      begin
        GetDate(y,m,d,dw);
        today := PackedDate(y,m,d);
      end;  { today }

    Function ordDate (Y,M,D : Word): LongInt;     { returns ordinal Date as yyddd }
    Var LYR  : Boolean;
        TEMP : LongInt;
    begin
      LYR := (Y mod 4 = 0) and (Y <> 1900);
      Dec (Y,1900);
      TEMP := LongInt(Y) * 1000;
      Inc (TEMP,TDays[LYR][M-1]);    { Compute # days through last month }
      Inc (TEMP,D);                                  { # days this month }
      ordDate := TEMP
    end;  { ordDate }

    Function Dateord (S : String) : String;    { returns Date as 'yymmdd' }
    Var LYR   : Boolean;
        Y,M,D : Word;
        TEMP  : LongInt;
        N     : Integer;
        StoP  : Boolean;
        SW,ST : String[6];
    begin
      Val (Copy(S,1,2),Y,N); Val (Copy(S,3,3),TEMP,N);
      Inc (Y,1900); LYR := (Y mod 4 = 0) and (Y <> 1900); Dec (Y,1900);
      N := 0; StoP := False;
      While not StoP and (TDays[LYR][N] < TEMP) do
        Inc (N);
      M := N;                                                     { month }
      D := TEMP-TDays[LYR][M-1];        { subtract # days thru this month }
      Str(Y:2,SW); Str(M:2,ST);
      if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
      Str(D:2,ST);
      if ST[1] = ' ' then ST[1] := '0'; SW := SW+ST;
      Dateord := SW
    end;  { Dateord }

    end.  { Unit TCDate }

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