![[NEW]](/file/23368/Chip_1998-07_cd.bin/zkuste/delphi/uddf/IMAGES/NEW.JPG)
From: Joe Nodeland <joe_nodeland@sunshine.net>
function TtheCalendar.CalcEaster:String;
var B,D,E,Q:Integer;
GF:String;
begin
B:=225-11*(Year Mod 19);
D:=((B-21)Mod 30)+21;
If D>48 then Dec(D);
E:=(Year+(Year Div 4)+D+1)Mod 7;
Q:=D+7-E;
If Q<32 then begin
If ShortDateFormat[1]='d' then
Result:=IntToStr(Q)+'/3/'+IntToStr(Year)
else Result:='3/'+IntToStr(Q)+'/'+IntToStr(Year);
end
else begin
If ShortDateFormat[1]='d' then
Result:=IntToStr(Q-31)+'/4/'+IntToStr(Year)
else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);
end;
{calc good friday}
If Q<32 then begin
If ShortDateFormat[1]='d' then GF:=IntToStr(Q-2)+'/3/'+IntToStr(Year)
else GF:='3/'+IntToStr(Q-2)+'/'+IntToStr(Year);
end
else begin
If ShortDateFormat[1]='d' then
GF:=IntToStr(Q-31-2)+'/4/'+IntToStr(Year)
else GF:='4/'+IntToStr(Q-31-2)+'/'+IntToStr(Year);
end;
end;
From: johan@lindgren.pp.se
Someone asked for a function to return the daynumber.This is my routines for such.
unit datefunc;
interface
function checkdate (date : string) :boolean;
function Date2julian (date : string) : longint;
function Julian2date (julian : longint) : string;
function DayOfTheWeek (date : string) :string;
function idag : string;
implementation
uses
sysutils;
function idag () : string;
{Retrieves the current date and returns it in the form YYYYMMDD to be used
in the other functions in this unit.}
var
Year, Month, Day: Word;
begin
DecodeDate(Now, Year, Month, Day);
result := IntToStr(year)+ IntToStr(Month) +IntToStr(day);
end;
function Date2julian (date : string) : longint;
{Assumes the date in format YYYYMMDD.
If you have another format. Make a routine to
convert it first.}
var
month,day,year:integer;
ta,tb,tc : longint;
begin
month := strtoint(copy(date,5,2));
day := strtoint(copy(date,7,2));
year := strtoint(copy(date,1,4));
if month > 2 then
month := month - 3
else
begin
month := month + 9;
year := year - 1;
end;
ta := 146097 * (year div 100) div 4;
tb := 1461 * (year MOD 100) div 4;
tc := (153 * month + 2) div 5 + day + 1721119;
result := ta + tb + tc
end;
function mdy2date (month, day, year : integer) : string;
var
y,m,d : string;
begin
y := '000'+inttostr(year);
y := copy(y,length(y)-3,4);
m := '0'+inttostr(month);
m := copy(m,length(m)-1,2);
d := '0'+inttostr(day);
d := copy(d,length(d)-1,2);
result := y+m+d;
end;
function Julian2date (julian : longint) : string;
{Takes a value and returns a date in the form YYYYMMDD}
var
x,y,d,m : longint;
month,day,year : integer;
begin
x := 4 * julian - 6884477;
y := (x div 146097) * 100;
d := (x MOD 146097) div 4;
x := 4 * d + 3;
y := (x div 1461) + y;
d := (x MOD 1461) div 4 + 1;
x := 5 * d - 3;
m := x div 153 + 1;
d := (x MOD 153) div 5 + 1;
if m < 11 then
month := m + 2
else
month := m - 10;
day := d;
year := y + m div 11;
result := mdy2date(month, day, year);
end;
function checkdate (date : string) :boolean;
{Date must be in the form YYYYMMDD.}
var
julian : longint;
test : string;
begin
{First convert the datestring to julian single format.
This will always produce a value.}
julian := Date2julian(date);
{Then convert the value to a date.
This will always be a valid date. But if it is not the same
as date that was not a valid date.}
test := Julian2date(julian);
if date = test then
result := true
else
result := false;
end;
function DayOfTheWeek (date : string) :string;
{Takes a date in the form YYYYMMDD
Returns the weekday.}
var
julian : longint;
begin
julian := (Date2julian(date)) MOD 7;
case julian of
0 : result := 'Monday';
1 : result := 'Tuesday';
2 : result := 'Wednesday';
3 : result := 'Thursday';
4 : result := 'Friday';
5 : result := 'Saturday';
6 : result := 'Sunday';
end;
end;
end.
From: ksudar@erols.com (Karl Sudar)
Here is a BASIC program I found.. maybe someone can port it to pascal?(let me know about it, rdb@ktibv.nl)
10 ' Sunrise-Sunset 20 GOSUB 300 30 INPUT "Lat, Long (deg)";B5,L5 40 INPUT "Time zone (hrs)";H 50 L5=L5/360: Z0=H/24 60 GOSUB 1170: T=(J-2451545)+F 70 TT=T/36525+1: ' TT = centuries 80 ' from 1900.0 90 GOSUB 410: T=T+Z0 100 ' 110 ' Get Sun's Position 120 GOSUB 910: A(1)=A5: D(1)=D5 130 T=T+1 140 GOSUB 910: A(2)=A5: D(2)=D5 150 IF A(2)<A(1) THEN A(2)=A(2)+P2 160 Z1=DR*90.833: ' Zenith dist. 170 S=SIN(B5*DR): C=COS(B5*DR) 180 Z=COS(Z1): M8=0: W8=0: PRINT 190 A0=A(1): D0=D(1) 200 DA=A(2)-A(1): DD=D(2)-D(1) 210 FOR C0=0 TO 23 220 P=(C0+1)/24 230 A2=A(1)+P*DA: D2=D(1)+P*DD 240 GOSUB 490 250 A0=A2: D0=D2: V0=V2 260 NEXT 270 GOSUB 820: ' Special msg? 280 END 290 ' 300 ' Constants 310 DIM A(2),D(2) 320 P1=3.14159265: P2=2*P1 330 DR=P1/180: K1=15*DR*1.0027379 340 S$="Sunset at " 350 R$="Sunrise at " 360 M1$="No sunrise this date" 370 M2$="No sunset this date" 380 M3$="Sun down all day" 390 M4$="Sun up all day" 400 RETURN 410 ' LST at 0h zone time 420 T0=T/36525 430 S=24110.5+8640184.813*T0 440 S=S+86636.6*Z0+86400*L5 450 S=S/86400: S=S-INT(S) 460 T0=S*360*DR 470 RETURN 480 ' 490 ' Test an hour for an event 500 L0=T0+C0*K1: L2=L0+K1 510 H0=L0-A0: H2=L2-A2 520 H1=(H2+H0)/2: ' Hour angle, 530 D1=(D2+D0)/2: ' declination, 540 ' at half hour 550 IF C0>0 THEN 570 560 V0=S*SIN(D0)+C*COS(D0)*COS(H0)-Z 570 V2=S*SIN(D2)+C*COS(D2)*COS(H2)-Z 580 IF SGN(V0)=SGN(V2) THEN 800 590 V1=S*SIN(D1)+C*COS(D1)*COS(H1)-Z 600 A=2*V2-4*V1+2*V0: B=4*V1-3*V0-V2 610 D=B*B-4*A*V0: IF D<0 THEN 800 620 D=SQR(D) 630 IF V0<0 AND V2>0 THEN PRINT R$; 640 IF V0<0 AND V2>0 THEN M8=1 650 IF V0>0 AND V2<0 THEN PRINT S$; 660 IF V0>0 AND V2<0 THEN W8=1 670 E=(-B+D)/(2*A) 680 IF E>1 OR E<0 THEN E=(-B-D)/(2*A) 690 T3=C0+E+1/120: ' Round off 700 H3=INT(T3): M3=INT((T3-H3)*60) 710 PRINT USING "##:##";H3;M3; 720 H7=H0+E*(H2-H0) 730 N7=-COS(D1)*SIN(H7) 740 D7=C*SIN(D1)-S*COS(D1)*COS(H7) 750 AZ=ATN(N7/D7)/DR 760 IF D7<0 THEN AZ=AZ+180 770 IF AZ<0 THEN AZ=AZ+360 780 IF AZ>360 THEN AZ=AZ-360 790 PRINT USING ", azimuth ###.#";AZ 800 RETURN 810 ' 820 ' Special-message routine 830 IF M8=0 AND W8=0 THEN 870 840 IF M8=0 THEN PRINT M1$ 850 IF W8=0 THEN PRINT M2$ 860 GOTO 890 870 IF V2<0 THEN PRINT M3$ 880 IF V2>0 THEN PRINT M4$ 890 RETURN 900 ' 910 ' Fundamental arguments 920 ' (Van Flandern & 930 ' Pulkkinen, 1979) 940 L=.779072+.00273790931*T 950 G=.993126+.0027377785*T 960 L=L-INT(L): G=G-INT(G) 970 L=L*P2: G=G*P2 980 V=.39785*SIN(L) 990 V=V-.01000*SIN(L-G) 1000 V=V+.00333*SIN(L+G) 1010 V=V-.00021*TT*SIN(L) 1020 U=1-.03349*COS(G) 1030 U=U-.00014*COS(2*L) 1040 U=U+.00008*COS(L) 1050 W=-.00010-.04129*SIN(2*L) 1060 W=W+.03211*SIN(G) 1070 W=W+.00104*SIN(2*L-G) 1080 W=W-.00035*SIN(2*L+G) 1090 W=W-.00008*TT*SIN(G) 1100 ' 1110 ' Compute Sun's RA and Dec 1120 S=W/SQR(U-V*V) 1130 A5=L+ATN(S/SQR(1-S*S)) 1140 S=V/SQR(U):D5=ATN(S/SQR(1-S*S)) 1150 R5=1.00021*SQR(U) 1160 RETURN 1165 ' 1170 ' Calendar --> JD 1180 INPUT "Year, Month, Day";Y,M,D 1190 G=1: IF Y<1583 THEN G=0 1200 D1=INT(D): F=D-D1-.5 1210 J=-INT(7*(INT((M+9)/12)+Y)/4) 1220 IF G=0 THEN 1260 1230 S=SGN(M-9): A=ABS(M-9) 1240 J3=INT(Y+S*INT(A/7)) 1250 J3=-INT((INT(J3/100)+1)*3/4) 1260 J=J+INT(275*M/9)+D1+G*J3 1270 J=J+1721027+2*G+367*Y 1280 IF F>=0 THEN 1300 1290 F=F+1: J=J-1 1300 RETURN 1310 ' 1320 ' This program by Roger W. Sinnott calculates the times of sunrise 1330 ' and sunset on any date, accurate to the minute within several 1340 ' centuries of the present. It correctly describes what happens in the 1350 ' arctic and antarctic regions, where the Sun may not rise or set on 1360 ' a given date. Enter north latitudes positive, west longitudes 1370 ' negative. For the time zone, enter the number of hours west of 1380 ' Greenwich (e.g., 5 for EST, 4 for EDT). The calculation is 1390 ' discussed in Sky & Telescope for August 1994, page 84.
I have a very urgent problem i am currently working on a college project where i have to check the validity of dates entered into a maskedit in this format - __/__/____ e.g. 12/12/1997.Ages ago, I did a very silly date encoder/decoder that did check that a date was valid. See code below.
function CheckDateFormat(SDate:string):string;
var
IDateChar:string;
x,y:integer;
begin
IDateChar:='.,\/';
for y:=1 to length(IDateChar) do
begin
x:=pos(IDateChar[y],SDate);
while x>0 do
begin
Delete(SDate,x,1);
Insert('-',SDate,x);
x:=pos(IDateChar[y],SDate);
end;
end;
CheckDateFormat:=SDate;
end;
function DateEncode(SDate:string):longint;
var
year,month,day:longint;
wy,wm,wd:longint;
Dummy:TDateTime;
Check:integer;
begin
DateEncode:=-1;
SDate:=CheckDateFormat(SDate);
Val(Copy(SDate,1,pos('-',SDate)-1),day,check);
Delete(Sdate,1,pos('-',SDate));
Val(Copy(SDate,1,pos('-',SDate)-1),month,check);
Delete(SDate,1,pos('-',SDate));
Val(SDate,year,check);
wy:=year;
wm:=month;
wd:=day;
try
Dummy:=EncodeDate(wy,wm,wd);
except
year:=0;
month:=0;
day:=0;
end;
DateEncode:=(year*10000)+(month*100)+day;
end;
Hi, this is a source of a function DateSer I wrote, because I worked in VB
before, and this was a very useful function. Delphi unfortunately doesn't
have it. Use it in a form of
DecodeDate(Date,y,m,d);
NewDate:=DateSer(y-4,m+254,d+1234);
or something like that.... function DateSer(y,m,d: Integer): TDateTime;
const
mj: array[1..12] of Integer=(31,28,31,30,31,30,31,31,30,31,30,31);
var
add: Integer;
begin
while(true) do begin
y:=y+(m-1) div 12;
m:= (m-1) mod 12 +1;
if m<=0 then begin
Inc(m,12);
Dec(y);
end;
if (y mod 4 = 0) and (m=2) then
add:=1 //add one day in February
else
add:=0;
if (d>0) and (d<=(mj[m]+add)) then break;
if d>0 then begin Dec(d,mj[m]+add); Inc(m); end
else begin Inc(d,mj[m]+add); Dec(m); end;
end;
Result:=EncodeDate(y,m,d);
end;