# 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
...