unit ProcedureDateTime;
{ ---------------------------------- }
{ written by Manfred Zenns 2008-2012 }
{ ---------------------------------- }
{ these f's and p's works from 1.1.0000 till 31.12.65535 }
{ note: year 02 means 0002 and not 2002, as 96 means 0096 and not 1996 }
{ the 1.st week of a year starts with a week have at least 4 days }
{ the 1.st day of a week is the monday }
{ some smileys if you try to calc ColumbusDay before 1492... }
{ or Christian holidays before 311... }
{ main target of this unit is NOT to use any other unit for its work - okay }
{---------------------------------------------------------------------------}
interface
// uses ProcedureUnit;
type __s2 =
string[2];
__s9 =
string[9];
__s11 =
string[11];
// on date, days, months, years
function isLeapYear(Y:word):boolean;
function getMonthDays(M,Y:word):longint;
function getYearDays(Y:word):longint;
function getTotalYearDays(D,M,Y:word):longint;
function getDaysSinceZero(D,M,Y:word):longint;
procedure getDateOfZeroDays(Days:longint;
var D,M,Y:word);
function getDate1BeforeDate2(D1,M1,Y1,D2,M2,Y2:word):boolean;
function getDaysBetweenDates(D1,M1,Y1,D2,M2,Y2:word):longint;
procedure getDateAfterAddDMY(Days,Months,Years:longint;
var D,M,Y:word);
procedure getDateAfterSubDMY(Days,Months,Years:longint;
var D,M,Y:word);
// on time, hours, minutes, seconds
function getSecsSinceZero(H,M,S:word):longint;
procedure getTimeOfZeroSecs(Secs:longint;
var H,M,S:word);
function getSecsBetweenTimes(H1,M1,S1,H2,M2,S2:word):longint;
procedure getTimeAfterAddHMS(Hours,Minutes,Secs:longint;
var H,M,S,Ovf:word);
procedure getTimeAfterSubHMS(Hours,Minutes,Secs:longint;
var H,M,S,Ovf:word);
// on weekdays, weeknumbers
function getDayOfWeek(D,M,Y:word):__s9;
function getIndexOfWeek(D,M,Y:word):longint;
procedure getDateFromWeekNumber(WeekNumber,Year:longint;
var D,M,Y:word);
function getWeekNumberFromDate(D,M,Y:word):longint;
// on specials
function getZodiacSign(D,M,Y:word):__s11;
// on holidays
procedure getEastern(Year:word;
var D,M,Y:word);
procedure getEasternAddDays(Year,AddDays:longint;
var D,M,Y:word);
procedure getAshWednesday(Year:word;
var D,M,Y:word);
procedure getGoodFriday(Year:word;
var D,M,Y:word);
procedure getChristiAscension(Year:word;
var D,M,Y:word);
procedure getWhitSunday(Year:word;
var D,M,Y:word);
procedure getCorpusChristi(Year:word;
var D,M,Y:word);
function getGermanHolidays:
string;
procedure getXthWeekDayOfMonthYear(X:byte;WeekDay:__s2;Month,Year:word;
var D,M,Y:word);
procedure getMartinLutherKingDay(Year:word;
var D,M,Y:word);
procedure getPresidentsDay(Year:word;
var D,M,Y:word);
procedure getMemorialDay(Year:word;
var D,M,Y:word);
procedure getLabourDay(Year:word;
var D,M,Y:word);
procedure getColumbusDay(Year:word;
var D,M,Y:word);
procedure getThanksgivingDay(Year:word;
var D,M,Y:word);
function getUSAHolidays:
string;
implementation
function isLeapYear(Y:word):boolean;
begin
result:=False;
if (Y
mod 4 = 0)
then begin
result:=True;
if (Y
mod 100 = 0)
then begin
result:=False;
if (Y
mod 400 = 0)
then result:=True;
end;
end;
end;
function getMonthDays(M,Y:word):longint;
begin
result:=-1;
case M
of
1,3,5,7,8,10,12: result:=31;
4,6,9,11: result:=30;
2:
if isLeapYear(Y)
then result:=29
else result:=28;
end;
{case}
end;
function getYearDays(Y:word):longint;
begin
result:=365-28+getMonthDays(2,Y);
end;
function getTotalYearDays(D,M,Y:word):longint;
var i, r : longint;
begin
r:=0;
for i:=1
to M-1
do inc(r,getMonthDays(i,Y));
inc(r,D);
result:=r;
end;
function getDaysSinceZero(D,M,Y:word):longint;
var i, r : longint;
begin
r:=getTotalYearDays(D,M,Y);
for i:=0
to Y-1
do inc(r,getYearDays(i));
result:=r;
end;
procedure getDateOfZeroDays(Days:longint;
var D,M,Y:word);
var hD, hM, hY : longint;
begin
hY:=-1;
while (Days > 0)
do begin
inc(hY);
dec(Days,getYearDays(hY));
end;
{while}
inc(Days,getYearDays(hY));
hM:=0; Y:=hY;
while (Days > 0)
do begin
inc(hM);
if (hM > 12)
then break;
dec(Days,getMonthDays(hM,Y));
end;
{while}
if (hM <= 12)
then inc(Days,getMonthDays(hM,Y));
hD:=Days;
D:=hD; M:=hM;
end;
function getDate1BeforeDate2(D1,M1,Y1,D2,M2,Y2:word):boolean;
begin {-is Date1 before Date2 then return true-}
result:=(getDaysSinceZero(D1,M1,Y1) > getDaysSinceZero(D2,M2,Y2));
end;
function getDaysBetweenDates(D1,M1,Y1,D2,M2,Y2:word):longint;
var dsz1, dsz2 : longint;
begin
dsz1:=getDaysSinceZero(D1,M1,Y1);
dsz2:=getDaysSinceZero(D2,M2,Y2);
result:=abs(dsz1-dsz2);
end;
procedure getDateAfterAddDMY(Days,Months,Years:longint;
var D,M,Y:word);
var dsz, hM : longint;
begin
dsz:=getDaysSinceZero(D,M,Y);
inc(dsz,Days);
getDateOfZeroDays(dsz,D,M,Y);
hM:=M; inc(hM,Months); inc(Y,Years);
while (hM > 12)
do begin inc(Y);
dec(hM,12);
end;
M:=hM;
end;
procedure getDateAfterSubDMY(Days,Months,Years:longint;
var D,M,Y:word);
var dsz, hM, hY : longint;
begin
dsz:=getDaysSinceZero(D,M,Y);
dec(dsz,Days);
if (dsz > 0)
then begin
getDateOfZeroDays(dsz,D,M,Y);
hM:=M; hY:=Y;
dec(hM,Months);
dec(hY,Years);
while (hM < 1)
do begin dec(hY); inc(hM,12);
end;
if (hM > 0)
then M:=hM
else M:=0;
if (hY > 0)
then Y:=hY
else Y:=0;
end else begin
D:=0; M:=0; Y:=0;
end;
end;
//
function getSecsSinceZero(H,M,S:word):longint;
begin
result:=longint(H)*3600+
longint(M)*60+
longint(S);
end;
procedure getTimeOfZeroSecs(Secs:longint;
var H,M,S:word);
var hH, hM : longint;
begin
Secs:=Secs
mod 86400;
hH:=(Secs
div 3600);
dec(Secs,hH*3600); H:=hH;
hM:=(Secs
div 60);
dec(Secs,hM*60); M:=hM;
S:=Secs;
end;
function getSecsBetweenTimes(H1,M1,S1,H2,M2,S2:word):longint;
var ssz1, ssz2 : longint;
begin
ssz1:=getSecsSinceZero(H1,M1,S1);
ssz2:=getSecsSinceZero(H2,M2,S2);
result:=abs(ssz1-ssz2);
end;
procedure getTimeAfterAddHMS(Hours,Minutes,Secs:longint;
var H,M,S,Ovf:word);
var ssz : longint;
begin
ssz:=getSecsSinceZero(H,M,S);
inc(ssz,Secs+Minutes*60+Hours*3600);
Ovf:=ssz
div 86400;
ssz:=ssz
mod 86400;
getTimeOfZeroSecs(ssz,H,M,S);
end;
procedure getTimeAfterSubHMS(Hours,Minutes,Secs:longint;
var H,M,S,Ovf:word);
var ssz : longint;
begin
ssz:=getSecsSinceZero(H,M,S);
dec(ssz,Secs+Minutes*60+Hours*3600); Ovf:=0;
while (ssz < 0)
do begin inc(Ovf); inc(ssz,86400);
end;
getTimeOfZeroSecs(ssz,H,M,S);
end;
//
function getDayOfWeek(D,M,Y:word):__s9;
var dsz : longint;
begin
dsz:=getDaysSinceZero(D,M,Y);
dsz:=dsz
mod 7;
case dsz
of
0: result:='
Friday'; 1: result:='
Saturday';
2: result:='
Sunday'; 3: result:='
Monday';
4: result:='
Tuesday'; 5: result:='
Wednesday';
6: result:='
Thursday';
end;
{case}
end;
function getIndexOfWeek(D,M,Y:word):longint;
var dsz : longint;
begin
dsz:=getDaysSinceZero(D,M,Y);
result:=dsz
mod 7;
{0='Friday' .. 6='Thursday'}
end;
procedure getDateFromWeekNumber(WeekNumber,Year:longint;
var D,M,Y:word);
var dow :
string[2];
days : longint;
begin
{first day of a week is the Monday}
{first week is a min 4 days week}
dec(WeekNumber); D:=1; M:=1; Y:=Year;
dow:=copy(getDayOfWeek(1,1,Year),1,2);
{the 1.1.year is monday...}
if (dow='
Mo')
then days:=7*WeekNumber
else
if (dow='
Tu')
then begin
if (WeekNumber = 0)
then begin
D:=31; M:=12;
dec(Y); exit;
end else
days:=7*WeekNumber-1;
end else
if (dow='
We')
then begin
if (WeekNumber = 0)
then begin
D:=30; M:=12;
dec(Y); exit;
end else
days:=7*WeekNumber-2;
end else
if (dow='
Th')
then begin
if (WeekNumber = 0)
then begin
D:=29; M:=12;
dec(Y); exit;
end else
days:=7*WeekNumber-3;
end else
{the 1.1.year is friday... now we have not longer a 4 days week}
if (dow='
Fr')
then begin
if (WeekNumber = 0)
then begin
D:=4; exit;
end else
days:=7*WeekNumber+3;
end else
if (dow='
Sa')
then begin
if (WeekNumber = 0)
then begin
D:=3; exit;
end else
days:=7*WeekNumber+2;
end else
if (dow='
Su')
then begin
if (WeekNumber = 0)
then begin
D:=2; exit;
end else
days:=7*WeekNumber+1;
end;
getDateAfterAddDMY(days,0,0,D,M,Y);
end;
function getWeekNumberFromDate(D,M,Y:word):longint;
var dow :
string[2];
days, sub : longint;
begin
dow:=copy(getDayOfWeek(1,1,Y),1,2);
days:=getTotalYearDays(D,M,Y);
{the 1.1.year is monday...}
if (dow='
Mo')
then sub:=1
else
if (dow='
Tu')
then sub:=0
else
if (dow='
We')
then sub:=-1
else
if (dow='
Th')
then sub:=-2
else
{the 1.1.year is friday... now we have not longer a 4 days week}
if (dow='
Fr')
then begin
if ((M=1)
and (D<4))
then begin
result:=getWeekNumberFromDate(28,12,Y-1); exit;
end else
sub:=+4
end else
if (dow='
Sa')
then begin
if ((M=1)
and (D<3))
then begin
result:=getWeekNumberFromDate(27,12,Y-1); exit;
end else
sub:=+3
end else
if (dow='
Su')
then begin
if ((M=1)
and (D<2))
then begin
result:=getWeekNumberFromDate(26,12,Y-1); exit;
end else
sub:=+2;
end;
{possible values 1..52, 53 -> 1}
result:=1+((days-sub)
div 7);
if (result > 52)
then result:=1;
end;
function getZodiacSign(D,M,Y:word):__s11;
var days : longint;
begin
days:=getTotalYearDays(D,M,Y);
if (days>= 21)
and (days<= 49)
then result:='
Aquarius';
if (days>= 50)
and (days<= 79)
then result:='
Pisces';
if (days>= 80)
and (days<=111)
then result:='
Aries';
if (days>=112)
and (days<=141)
then result:='
Taurus';
if (days>=142)
and (days<=172)
then result:='
Gemini';
if (days>=173)
and (days<=203)
then result:='
Cancer';
if (days>=204)
and (days<=235)
then result:='
Leo';
if (days>=236)
and (days<=266)
then result:='
Virgo';
if (days>=267)
and (days<=296)
then result:='
Libra';
if (days>=297)
and (days<=326)
then result:='
Scorpio';
if (days>=327)
and (days<=355)
then result:='
Sagittarius';
if (days>=355)
or (days<= 20)
then result:='
Capricorn';
end;
procedure getEastern(Year:word;
var D,M,Y:word);
var a,b,c,v4,e,hD,hM,days : longint;
dow :
string[2];
begin
Y:=Year;
a:=y
mod 19; b:=y
mod 4; c:=y
mod 7; v4:=(19*a+24)
mod 30;
e:=(2*b+4*c+6*v4+5)
mod 7; hD:=22+v4+e; hM:=3;
if (hD>31)
then begin hD:=v4+e-9; hM:=4;
end;
if ((hD=26)
and (hM=4))
then hD:=19;
if ((hD=25)
and (hM=4)
and (v4=28)
and (e=6)
and (a>10))
then hD:=18;
D:=hD; M:=hM;
days:=getDaysSinceZero(D,M,Y);
dow:=copy(getDayOfWeek(D,M,Y),1,2);
if (dow='
Su')
then {okay} else
if (dow='
Mo')
then dec(days)
else
if (dow='
Tu')
then dec(days,2)
else
if (dow='
We')
then dec(days,3)
else
if (dow='
Th')
then inc(days,3)
else
if (dow='
Fr')
then inc(days,2)
else
if (dow='
Sa')
then inc(days);
getDateOfZeroDays(days,D,M,Y);
end;
procedure getEasternAddDays(Year,AddDays:longint;
var D,M,Y:word);
var days : longint;
begin
getEastern(Year,D,M,Y);
days:=getDaysSinceZero(D,M,Y)+AddDays;
getDateOfZeroDays(days,D,M,Y);
end;
procedure getAshWednesday(Year:word;
var D,M,Y:word);
begin {AscherMittwoch -46}
getEasternAddDays(Year,-46,D,M,Y);
end;
procedure getGoodFriday(Year:word;
var D,M,Y:word);
begin {KarFreitag -2}
getEasternAddDays(Year,-2,D,M,Y);
end;
procedure getChristiAscension(Year:word;
var D,M,Y:word);
begin {Christi Himmelfahrt +39}
getEasternAddDays(Year,+39,D,M,Y);
end;
procedure getWhitSunday(Year:word;
var D,M,Y:word);
begin {PfingstSonntag +49}
getEasternAddDays(Year,+49,D,M,Y);
end;
procedure getCorpusChristi(Year:word;
var D,M,Y:word);
begin {Fronleichnam +60}
getEasternAddDays(Year,+60,D,M,Y);
end;
function getGermanHolidays:
string;
begin {}
result:='
NeuJahr=1.1.,'+
'
MaiFeiertag=1.5.,'+
'
TagDerDeutschenEinheit=3.10.,'+
'
Reformationstag=31.10.,'+
'
Weihnachten=24-26.12.';
end;
procedure getXthWeekDayOfMonthYear(X:byte;WeekDay:__s2;Month,Year:word;
var D,M,Y:word);
var f,lastf,i: byte;
dow : __s2;
begin
f:=0; lastf:=0; M:=Month; Y:=Year;
for i:=1
to 31
do begin
dow:=copy(getDayOfWeek(i,M,Y),1,2);
if (dow=WeekDay)
then begin inc(f); lastf:=i;
end;
if (f=X)
then begin D:=i; break;
end;
end;
D:=lastf;
{force to return the last WeekDay for X > 5}
end;
procedure getMartinLutherKingDay(Year:word;
var D,M,Y:word);
begin {MartinLutherKingDay is 3rd Monday in Jan}
getXthWeekDayOfMonthYear(3,'
Mo',1,Year,D,M,Y);
end;
procedure getPresidentsDay(Year:word;
var D,M,Y:word);
begin {PresidentsDay is 3rd Monday in Feb}
getXthWeekDayOfMonthYear(3,'
Mo',2,Year,D,M,Y);
end;
procedure getMemorialDay(Year:word;
var D,M,Y:word);
begin {PresidentsDay is LAST(255) Monday in May}
getXthWeekDayOfMonthYear(255,'
Mo',5,Year,D,M,Y);
end;
procedure getLabourDay(Year:word;
var D,M,Y:word);
begin {LabourDay is 1st Monday in Sep}
getXthWeekDayOfMonthYear(1,'
Mo',9,Year,D,M,Y);
end;
procedure getColumbusDay(Year:word;
var D,M,Y:word);
begin {ColumbusDay is 2nd Monday in Oct}
getXthWeekDayOfMonthYear(2,'
Mo',10,Year,D,M,Y);
end;
procedure getThanksgivingDay(Year:word;
var D,M,Y:word);
begin {ThanksgivingDay is 4th Thursday in Nov}
getXthWeekDayOfMonthYear(4,'
Th',11,Year,D,M,Y);
end;
function getUSAHolidays:
string;
begin {}
result:='
NewYearsDay=1.1.,'+
'
VeteransDay=11.11.,'+
'
ChristmasDay=25.12.';
end;
end.