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 ((y mod 100<>0) or (y mod 400=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;
Als je een Datumveld intypt in een Database, dan kun je het jaartal weglaten, omdat de computer die voor je invult met het huidige jaar. Kan zoiets ook in een gewoon Edit-veld?
Het antwoord is ja, dat kan met:
PROCEDURE TForm1.Edit1Exit(Sender: TObject); BEGIN IF Edit1.Text<>'' THEN BEGIN TRY StrToDate(Edit1.Text); EXCEPT Edit1.SetFocus; MessageBeep(0); raise Exception.Create('"'+Edit1.Text +'" is no valid Date'); END{try}; Edit1.Text:=DateToStr(StrToDate(Edit1.Text)); END{if}; END;