Board index » delphi » Week-numbers

Week-numbers

Hello All!

Can anyone confirm the two following functions, as I don't have the proper
calendars available:

  Function Week2date(Year, Week : Word) : Date;
  Var
    i      : Word;
    j      : Date;
  Begin
    j := DMYToDate(1, 1, Year);
    {Find first monday}
    i := (Ord(DayOfWeek(j)) <> 1);
    If (i = 0) then i := 6 else dec(i);
    if (i > 3) then
      Week2date := j + Week * 7 - i
    else
      Week2date := j + Pred(Week) * 7 - i;
  End {Week2date} ;

  {------------------------------------}

  Function WeekNr(dd : Date) : Word;
  Var
    d, m, y : Integer;
    j       : Date;
  Begin
    DateToDMY(dd, d, m, y);
    {Calculate julian for january 1st}
    j := DMYToDate(1, 1, y);
    d := Ord(DayOfWeek(j));
    {adjust programmers dow to Pred(actual dow)}
    If (d = 0) then d := 6 else Dec(d);
    If (d > 3) And (dd - j <= 6-d) then
    begin
        WeekNr := WeekNr(DMYToDate(31,12, Pred(y)))
    end
    Else
      If (d > 3) then
        WeekNr := (dd - j - (7 - d) + 7) div 7
      else
        WeekNr := (dd - j + d + 7) div 7;
  end {WeekNr};

Where:
  Date is a julian date (e.g.: Word or longint).
  DMYToDate converts the day, month and, year into a julian date.
  DateToDMY converts a julian date into day, month and, year.
  DayOfWeek calculates the day of the week of a julian date (0=sunday).
(If you have OPro or TPro you'll find them in OpDate/TpDate, otherwise TCDate
is very similar in that respect).
                                                                Ping.
p...@night.ping.dk
P.H.Rankin Hansen, Birkeh?j 7, 5700 Svendborg, Danmark

 

Re:Week-numbers


In article <753_9609082...@night.ping.dk> of Sun, 8 Sep 1996 13:07:34 in
comp.lang.pascal.borland, Ping Hansen <Ping.Han...@p58.f11.n237.z1.fidon

Quote
et.org> wrote:
>Can anyone confirm the two following functions, as I don't have the
>proper calendars available:

Code snipped; it calls routines not given.

Quote
>Where:
>  Date is a julian date (e.g.: Word or longint).
>  DMYToDate converts the day, month and, year into a julian date.
>  DateToDMY converts a julian date into day, month and, year.
>  DayOfWeek calculates the day of the week of a julian date (0=sunday).
>(If you have OPro or TPro you'll find them in OpDate/TpDate, otherwise TCDate
>is very similar in that respect).

Seems unlikely to be absolutely correct, because the Julian Date changes
at NOON - and ceased to fit into a word well before 4500BC.  Possibly
you mean the Modified Julian Date (MJD=JD-2400000.5) which started in (I
think) late 1858.  Certainly MJD 50000 was 95/10/10.

--
John Stockton, Surrey, UK.  J...@merlyn.demon.co.uk  Turnpike v1.12  MIME
     http://www.merlyn.demon.co.uk/

Re:Week-numbers


Hello Dr!

Monday September 09 1996 23:14, Dr John Stockton wrote to All:

 DJS> @GID GIGO+ sn 404 at night vsn 0.99.950801
 DJS> From: Dr John Stockton <j...@merlyn.demon.co.uk>
 DJS> Subject: Re: Week-numbers

 DJS> In article <753_9609082...@night.ping.dk> of Sun, 8 Sep 1996 13:07:34 in
 DJS> comp.lang.pascal.borland, Ping Hansen <Ping.Han...@p58.f11.n237.z1.fidon

Quote
 et.org>> wrote:

 >> Can anyone confirm the two following functions, as I don't have the
 >> proper calendars available:

 DJS> Code snipped; it calls routines not given.

I normally use OPDate from OPro, but here is a unit with similar code>
=== Cut ===
UNIT TCDate; { version 2.01 dated 31/05/92 }

  { Author: Trevor J Carlsen  Released into the public domain }
  {         PO Box 568                                        }
  {         Port Hedland                                      }
  {         Western Australia 6721                            }
  {         Voice (Deceased)                                  }
  {         Data  (Deceased)                                  }

interface

uses dos;

type
  Date          = word;
  UnixTimeStamp = longint;

const
  WeekDays   : array[0..6] of string[9] =
               ('s?ndag','mandag','tirsdag','onsdag','torsdag',
                'fredag','l?rdag');
  months     : array[1..12] of string[9] =
               ('januar','februar','marts','april','maj','juni','juli',
                'august','september','oktober','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; {!!2.00}
 { 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);
 {!!2.00 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 Today : date;
 { returns the number of days since 01-01-1900                        }

{=============================================================================

Quote
}

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); {!!2.00}

function DayOfTheWeek(pd : date): byte;
  begin
    DayOfTheWeek := pd mod 7;
  end;

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;{!!2.00}
  { Returns the number of seconds since 00:00 01/01/1970 }
  var
    temp     : UnixTimeStamp;
  begin
    temp     := 86400 * (PackedDate(yr,mth,d) - UnixDatum);
    UnixTime := temp + longint(hr) * 3600 + min * 60 + sec; {!!2.01}
  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);
    {!!2.00}
    var
      temp : UnixTimeStamp;
    begin
      UnPackDate(yr,mth,d,date(uts div 86400) + UnixDatum);
      temp   := uts mod 86400;
      hr     := temp div 3600;
      min    := (temp mod 3600) div 60;
      sec    := temp mod 60;
    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 = 31 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;

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 }
    If (y < 78) then Inc(y, 2000) else
      If (y < 1900) then Inc(y, 1900) else

  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;

function Today : date;
  var y,m,d,dw : word;
  begin
    GetDate(y,m,d,dw);
    Today := PackedDate(y,m,d);
  end;

end.  { Unit
...

read more »

Other Threads