با تشکر
و با اجازه چپ به راستش کردم:
Function _DATE_Inc(Var d : RecDate;Language : Integer) : RecDate;
Begin
Inc(d.Day);
if(d.Day > _DATE_MonthLength(d.Year, d.Mon, Language)) Then
Begin
d.Day := 1;
if(d.Mon >= 12) Then
Begin
d.Mon := 1;
Inc(d.Year);
End
else
Inc(d.Mon);
End;
_DATE_Inc := d;
End;
{------------------------------------------------------------------------------}
Procedure DATE_ToEnglish(Var d : RecDate);
Var
td, sd : RecDate;
Days : Integer;
Begin
sd := d;
if d.Year < 100 Then
d.Year := d.Year + 1300
else
d.Year := d.Year + 0;
Days := _DATE_PassedDaysOfYear(d, FARSI) - 288;
inc(d.Year, 621);
if Days <= 0 Then
Inc(Days, 365);
_DATE_DateOfPassedDays(d, Days, ENGLISH);
td := d;
// td := DATE_ToFarsi(td);
while DATE_Comp(td, sd) < 0 do
Begin
_DATE_Inc(d, ENGLISH);
td := d;
// DATE_ToFarsi(td);
End;
End;
{------------------------------------------------------------------------------}
Function FARSIDATE_TO_ENGLISHDATE(FarsiDate:String):String;
var
K,H:RecDate;
ll,yf,mf,df:word;
begin
K.Year:= strtoint(Copy(FarsiDate,1,4));
K.Mon := strtoint(Copy(FarsiDate,6,2));
K.Day := strtoint(Copy(FarsiDate,9,2));
yf:=k.Year;mf:=k.Mon;df:=k.Day;
case K.Mon of
1:begin
if (K.Day>=1) and (K.Day<=11) then
begin
H.Day:=K.Day+20;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-11;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
2:begin
if (K.Day>=1) and (K.Day<=10) then
begin
H.Day:=K.Day+20;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-10;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
3:begin
if (K.Day>=1) and (K.Day<=10) then
begin
H.Day:=K.Day+21;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-10;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
4:begin
if (K.Day>=1) and (K.Day<=9) then
begin
H.Day:=K.Day+21;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-9;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
5:begin
if (K.Day>=1) and (K.Day<=9) then
begin
H.Day:=K.Day+22;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-9;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
6:begin
if (K.Day>=1) and (K.Day<=9) then
begin
H.Day:=K.Day+22;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-9;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
7:begin
if (K.Day>=1) and (K.Day<=8) then
begin
H.Day:=K.Day+22;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-8;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
8:begin
if (K.Day>=1) and (K.Day<=9) then
begin
H.Day:=K.Day+22;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-9;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
9:begin
if (K.Day>=1) and (K.Day<=9) then
begin
H.Day:=K.Day+21;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-9;
H.Mon:=K.Mon+3;
H.Year:=K.Year+621;
end
end;
10:begin
if (K.Day>=1) and (K.Day<=10) then
begin
H.Day:=K.Day+21;
H.Mon:=K.Mon+2;
H.Year:=K.Year+621;
end
else
begin
H.Day:=K.Day-10;
H.Mon:=K.Mon-9;
H.Year:=K.Year+622;
end
end;
11:begin
if (K.Day>=1) and (K.Day<=11) then
begin
H.Day:=K.Day+20;
H.Mon:=K.Mon-10;
H.Year:=K.Year+622;
end
else
begin
H.Day:=K.Day-11;
H.Mon:=K.Mon-9;
H.Year:=K.Year+622;
end
end;
12:begin
if (K.Day>=1) and (K.Day<=9) then
begin
H.Day:=K.Day+19;
H.Mon:=K.Mon-10;
H.Year:=K.Year+622;
end
else
begin
H.Day:=K.Day-9;
H.Mon:=K.Mon-9;
H.Year:=K.Year+622;
end
end;
end;{Case}
{**** KABISE ****}
if (mf=12)and(df=10)and(h.Year mod 4=0) then
begin
h.Mon:=2;
h.Day:=29;
end;
if (h.Year mod 4 =0)and(h.Mon>2) then
h.Day:=h.Day-1;
if (h.Year mod 4 = 0)and (h.Day=0) then
begin
H.Mon:=h.Mon-1;
case h.Mon of
3:h.Day:=31;
4:h.Day:=30;
5:h.Day:=31;
6:h.Day:=30;
7:h.Day:=31;
8:h.Day:=31;
9:h.Day:=30;
10:h.Day:=31;
11:h.Day:=30;
12:h.Day:=31;
end;
end;
ll:=(h.Year -1) mod 4;
if (mf=10)and(df=11)and(ll =0) then
begin
h.Year:=h.Year-1;
h.Mon:=12;
h.Day:=31;
end;
FARSIDATE_TO_ENGLISHDATE:=IntToStr(H.Day)+'/'+IntToStr(H.Mon)+'/'+IntToStr(H.Year);
end;
و میلادی به شمسی :
Function DateToFarsi(InputDate : TDatetime):string;
Var
Days : Integer;
d : RecDate;
Buf : string;
Begin
DecodeDate(InputDate,d.year,d.mon,d.day);
//--------------
if d.Year < 100 Then
d.Year := d.Year + 1900
Else
d.Year := d.Year + 0;
Days := _DATE_PassedDaysOfYear(d, ENGLISH) - 79;
if Days > 0 Then
d.Year := d.Year - 621
else
d.Year := d.Year - 622;
if(Days < 0) Then
Begin
if _DATE_Leap(d.Year, FARSI) = True Then
Days := Days + 366
else
Days := Days + 365;
End;
_DATE_DateOfPassedDays(d, Days, FARSI);
//--------------
Buf := inttostr(d.year) + '/';
if d.mon < 10 then
Buf := Buf + '0' + inttostr(d.mon) + '/'
else
Buf := Buf + inttostr(d.mon) + '/';
if d.day < 10 then
Buf := Buf + '0' + inttostr(d.day)
else
Buf := Buf + inttostr(d.day);
DateToFarsi := Buf;
End;
پاسخ با نقل قول
