دالة التحويل من التاريخ الميلادي إلي التاريخ الهجري.

كود :
function DateToHijer(day:word;month:word;year:word):string;
var
ayear,cdays,leap,HMO,cmonth:word;
myear,cyear,cday,HDAY,Precise,mday:real;
function Pcision(F:real):real;
var
Status :boolean;
Dn :integer;
jDn,Fn,Fn2 :real;
function Moon(jd:real):real;
var
T,mE,mA,SmA,D,S,M,phaseAngle,iiF:real;
function r(Input:real):real;
var Output : real;
Begin
if (Input>=0) Then  Output := Input-Floor(Input/360)*360
else  Output := Input-Ceil((Input/360)*360+360);
Result := (Output);
End;
function radd(angle:real):real;
Begin
Result :=(r(angle)*PI/180);
End;
function sinn(angle:real):real;
Begin
Result :=(sin(radd(angle)));
End;
function coss(angle:real):real;
Begin
Result := (cos(radd(angle)));
End;
Begin
T := (jd-2451545)/36525.0;
mE := 297.8502042+445267.1115168*T-0.0016300*(T*T)+(T*T*T)/545868.0-(T*T*T*T)/113065000;
mA := 134.9634114+477198.8676313*T+0.0089970*(T*T)+(T*T*T)/69699.0-(T*T*T*T)/863310000.0;
SmA := 357.5291092+(35999.0502909*T)-(0.0001536*T*T)+((T*T*T)/24490000);
D := r(mE);
S := r(SmA);
M := r(mA);
phaseAngle := 180-D-6.289*sinn(M)+2.1*sinn(S)-1.274*sinn(r(2*D)-M)-0.658*sinn(2*D);
phaseAngle :=phaseAngle + (-0.214*sinn(2*M));
phaseAngle :=phaseAngle + (-0.110*sinn(1*D));
iiF := (1+coss(phaseAngle))/2*(phaseAngle/abs(phaseAngle));
Result :=(iiF);
End;
Begin
Status :=true;
Dn := 0;
jDn := F;
if (Moon(jDn-1)<=0) Then
Begin
jDn :=jDn- 1;
Dn :=Dn+ 1;
End;
while (Status = true) do
Begin
Fn := Moon(jDn);
Fn2 := Moon(jDn-1);
if (((Fn/abs(Fn))*(Fn2/abs(Fn2))) = 1) Then
Begin
Dn :=Dn + 1;
jDn :=jDn - 1;
End
else
Begin
if (abs(Fn*Fn2)< 0.2) Then 	Status :=false
else
Begin
Dn :=Dn + 1;
jDn :=jDn - 1;
End;
End;
End;
Result :=(Dn);
End;
procedure call(HdayN:real);
var
Gyear,GyearDf,Hyear,Hdayf,Hhday :real; 
l,Hmonth :word;
Gday :integer;
Begin
Gyear := cyear*0.970224044+621.574981435;
GyearDf := Gyear-Floor(Gyear);
Gyear :=Gyear- GyearDf;
l := 0;
if (Gyear/4 = Floor(Gyear/4)) Then
Begin
l := 1;
End;
if (Gyear/100 = Floor(Gyear/100)) Then
Begin
if (Gyear/400 <> Floor(Gyear/400)) Then
Begin
l := 0;
End;
End;
Gday := Floor((365+l)*GyearDf)+1;
Gyear :=Gyear+ Gday/(365+l);
Hyear := (Gyear-621.574981435)/0.970224044;
Hdayf := Hyear-Floor(Hyear);
Hhday := Hdayf*10631/30+1;
Hmonth := 1;
HdayF := 1;
while (HdayF<HdayN) Do
Begin
Hhday :=Hhday+ 1;
HdayF :=HdayF+ 1;
if (Hhday>=29.53058796) Then
Begin
Hhday := Hhday-29.53058796;
Hmonth :=Hmonth+ 1;
End;
End;
HDAY := Floor(Hhday)+1;
HMO := Hmonth;
End;
function JulianDay(gYear:integer; gMonth:word; gDay:word):real;
var
dayAndTime,jdd:real;
A:integer;
Begin
if (gMonth<=2) Then
Begin
gYear:=gYear-1;
gMonth :=gMonth + 12;
End;
A := Floor(gYear/100);
A := Floor(2-A+(A/4));
dayAndTime := gDay+0.8125;
jdd:=Floor(365.25*(gYear+4712))+Floor(30.6001*(gMonth+1))+dayAndTime+A-63.5;
Result := (jdd);
End;
Begin
ayear := year;
cdays := day;
leap := 0;
if (month>11) then cdays:=cdays+30;
if (month>10) then cdays:=cdays+31;
if (month>9) then cdays:=cdays+30;
if (month>8) then cdays:=cdays+31;
if (month>7) then cdays:=cdays+31;
if (month>6) then cdays:=cdays+30;
if (month>5) then cdays:=cdays+31;
if (month>4) then cdays:=cdays+30;
if (month>3) then cdays:=cdays+31;
if (month>2) then cdays:=cdays+28;
if (month>1) then cdays:=cdays+31;
if (ayear/4 = Floor(ayear/4))  Then leap := 1;
if (ayear/100 = Floor(ayear/100)) Then
if (ayear/400 <> Floor(ayear/400)) Then leap := 0;
if (leap = 1) Then 	if (month>2) Then cdays :=cdays+ 1;
myear := ayear+cdays/(365+leap);
cyear := (myear-621.578082192)/0.97022298;
cyear :=cyear+ Floor(abs(cyear)/3000)*30/10631;
cday := cyear-Floor(cyear);
cyear := cyear-cday;
if ((cday*10631/30)-Floor(cday*10631/30)<0.5) Then cday := Floor(cday*10631/30)+1
else
cday := Floor(cday*10631/30)+2;
call(cday);
mday := HDAY;
cmonth := HMO;
if (cmonth = 13) Then
Begin
month := 1;
cyear :=cyear+ 1;
End;
Precise := Pcision(JulianDay(ayear, month, day));
if (mday <> Precise) Then
Begin
if (mday = 1 ) AND ( Precise > 28) Then
Begin cmonth :=cmonth- 1;
if (cmonth = 0) Then
Begin cmonth := 12;
cyear :=cyear- 1;
End;
End
else
Begin
if (mday>28)  AND ( Precise<3) Then
Begin cmonth :=cmonth+ 1;
if (cmonth = 13) Then
Begin
cmonth := 1;
cyear :=cyear +1;
End;
End;
End;
End;
mday := Precise;
if (cyear<1) Then
Begin cyear :=cyear- 1;
End;
Result := floattostr( mday)+'/' + inttostr(cmonth)+'/' + floattostr( abs(cyear))
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption:=DateToHijer(17,03,2011);
end;