تبدیلِ تاریخ شمسی به میلادی و بالعکس.

[Dokht Esmati]

دوستان با این برنامه ای که نوشتم ، میتونن تاریخِ تولدشون یا هر تاریخِ دیگه رو ، به میلادی تبدیل کنن. (فلن فقت شمسی به میلادی رو داره)
بزودی سورسِ برنامه هم ارایه میشه.
[Only registered and activated users can see links]

[Dokht Esmati]

این هم سورس به زبانِ دلفی(2005).

[hamed198220]

با تشکر این لینک کار کرد و خود برنامه هم مشکلی نداشت. :icon_cool

[GhAeM]

خداييش خيلي با خودم كلنجار رفتم تا راضي شدم اين كد رو بزارم اينجا !
آخه آدرم دسترنج خودش رو راضي نميشه به همن راحتي پخش و پلا كنه !
حالا من كاري ندارم اين كدها قبلا بوده و يا هنوزم هست! اما اين كد نويسي ها كار خودمه !حداقل 3 سال پيش انكار رو كردم!
و حالا چون ارادت دارم به اين فروم اينجا ميذارم!
هر گونه كپي برداري در سايتها ديگه بدون ذكر PHALLS ممنوع است :)

خدايي مواظبش باشيد! خيلي براش زحمت كشيدم:
var
kabiseh:boolean;
dm,year,day,mon:string;
m1:integer;
c,b,b1,a:extended;
begin
year:=FormatDateTime('yyyy',date());
day:=FormatDateTime('dd',date());
mon:=FormatDateTime('mm',date());
dm:=FormatDateTime('mm/dd',date());
m1:=strtoint(year)*365+strtoint(day)-226743;
case strtoint(mon) of
2:m1:=m1+31;
3:m1:=m1+60;
4:m1:=m1+91;
5:m1:=m1+121;
6:m1:=m1+152;
7:m1:=m1+182;
8:m1:=m1+213;
9:m1:=m1+244;
10:m1:=m1+274;
11:m1:=m1+305;
12:m1:=m1+335;
end;
if int(strtoint(year)/4)*4<>strtoint(year) then
begin
if ((dm)>=('01/01'))and((dm)<=('02/28')) then
m1:=m1+1
else
m1:=m1-2;
end;
///////////////////////
a:=int(m1/365);
b1:=m1-a*365;
kabiseh:=false;
if int(strtoint(year)/4)*4=strtoint(year) then
begin
if b1=0 then
begin
c:=29;
b:=12;
a:=a-1;
end;
if b1=1 then
begin
c:=30;
b:=12;
a:=a-1;
kabiseh:=true;
c:=c+1;
end;
if (b1>=2)and(dm>'03/20') then
b1:=b1-1
end;
if b1=0 then
if int(strtoint(year)/4)*4<>strtoint(year) then
begin
c:=29;
b:=12;
a:=a-1;
end;
if (b1>=1)and(b1<=31)and(kabiseh=false) then
begin
c:=b1;
b:=1;
end;
if (b1>31)and(b1<=62) then
begin
c:=b1-31;
b:=2;
end;
if (b1>62)and(b1<=93) then
begin
c:=b1-62;
b:=3;
end;
if (b1>93)and(b1<=124) then
begin
c:=b1-93;
b:=4;
end;
if (b1>124)and(b1<=155) then
begin
c:=b1-124;
b:=5;
end;
if (b1>155)and(b1<=186) then
begin
c:=b1-155;
b:=6;
end;
if (b1>186)and(b1<=216) then
begin
c:=b1-186;
b:=7;
end;
if (b1>216)and(b1<=246) then
begin
c:=b1-216;
b:=8;
end;
if (b1>246)and(b1<=276) then
begin
c:=b1-246;
b:=9;
end;
if (b1>276)and(b1<=306) then
begin
c:=b1-276;
b:=10;
end;
if (b1>306)and(b1<=336) then
begin
c:=b1-306;
b:=11;
end;
if (b1>336) then
begin
c:=b1-336;
b:=12;
end;
label1.caption:=floattostr(a)+'/'+floattostr(b)+'/'+floattostr(c);
منتظر نظرات و اشكالات شما هستم.

[Foroud]

سلام آقاي غفوري

اگر مايل باشيد من هم Source خودم را مي گذارم يا برايتان بفرستم تا بتوانيم يك Component خوب و كامل براي تاريخ شمسي و ميلادي و تقويم فارسي ايجاد كنيم

[GhAeM]

خوشحال ميشم!
همينجا در خدمت هستم

[bromideh]

خيلي مفيد بود و واقعاً متشكرم.

[Foroud]

سلام

من سورس DLL‌ را قرار دادم اما فكر كنم بعد از اين هم تغييراتي در آن ايجاد كرده باشم اين بايد قديمي باشد فردا جديد آنرا قرار مي دهم



unit DateFarsi;

interface
procedure DateF (Y,M,D,DW:word; var YF,MF,DF,DWF:word);
procedure DateM (Y,M,D,DW:WORD;VAR YM,MM,DM,DWM:WORD);

implementation

function TestF(Y:word):boolean;
begin
TestF:= False;
if ((Y-(TRUNC ((Y-12)/29)*29+12)) MOD 4=0) AND
(((Y+1)-(TRUNC (((Y+1)-12)/29)*29+12)) MOD 4<>0) THEN
TESTF:=TRUE;
end;

function TESTM (Y:WORD):BOOLEAN;
begin
TESTM:=FALSE;
IF (Y MOD 4=0) THEN
TESTM:=TRUE;
end;

PROCEDURE DATEM (Y,M,D,DW:WORD;VAR YM,MM,DM,DWM:WORD);
CONST
{ ù¨‏“î ü¨ُھ ٌ‘¨}
SH_YEAR366 : ARRAY [1..12] OF
INTEGER=(00,00,01,01,02,02,02,02,01,01,00,-1);
{ üَُّمُ ٌ‘¨ }
YEARS : ARRAY [1..12] OF
INTEGER=(01,01,02,02,03,03,03,03,02,02,01,00);
VAR
Y1,M1,D1 : INTEGER;
SH_YEAR,M_YEAR : INTEGER;
GG : BOOLEAN;
MKABISEH,SKABISEH : BOOLEAN;
MKABISEHB,SKABISEHB : BOOLEAN;
MKABISEHN,SKABISEHN : BOOLEAN;
BEGIN
GG:=TRUE;
SH_YEAR :=1377;
M_YEAR :=1998;{ 21/3/1998}
DWM:=DW;
D1:=D-1;
M1:=M-1;
Y1:=Y-Y;
M_YEAR :=M_YEAR+(Y-SH_YEAR);
MM:=3+M1;
YM:=M_YEAR+Y1;
MKABISEH:=TESTM (YM);
SKABISEH:=TESTF (Y);
MKABISEHB:=TESTM (YM-1);
SKABISEHB:=TESTF (Y-1);
MKABISEHN:=TESTM (YM+1);
SKABISEHN:=TESTF (Y+1);
IF (NOT MKABISEH) AND (NOT SKABISEH) THEN
DM:=20+D1+(YEARS [M])
ELSE
IF (MKABISEH) AND (SKABISEHB) THEN
DM:=21+D1+(YEARS [M])
ELSE
IF ((NOT MKABISEHN) AND (SKABISEH))
OR (MKABISEHB) THEN
DM:=20+D1+(SH_YEAR366 [M]);
GG:=TRUE;
REPEAT
IF (DM>31) AND (MM IN [1,3,5,7,8,10,12]) THEN
BEGIN
DM:=DM-31;
MM:=MM+1;
END
ELSE
IF (DM>30) AND (MM IN [4,6,9,11]) THEN
BEGIN
DM:=DM-30;
MM:=MM+1;
END
ELSE
IF (DM>28) AND (MM=2) AND (NOT MKABISEH) THEN
BEGIN
DM:=DM-28;
MM:=MM+1;
END
ELSE
IF (DM>29) AND (MM=2) AND (MKABISEH) THEN
BEGIN
DM:=DM-29;
MM:=MM+1;
END
ELSE
GG:=FALSE;
IF (MM>12) THEN
BEGIN
MM:=MM-12;
YM:=YM+1;
GG:=TRUE;
END
ELSE
GG:=FALSE;
UNTIL GG=FALSE;
END; {END PROCEDURE}

procedure DateF(Y,M,D,DW:word; var YF,MF,DF,DWF:word);
CONST
{ Sal Miladi Kabiseh }
M_YEAR366 : ARRAY [1..12] OF
INTEGER=(00,01,00,02,01,01,00,00,00,-1,00,00);
{ Sal Shamsi Kabiseh }
SH_YEAR366 : ARRAY [1..12] OF
INTEGER=(00,01,-1,00,-1,-1,-2,-2,-2,-3,-2,-2);
{ . –¨گ ù¨‏“î ü¢ٍ‏ُ ٌ‘¨ ّ ù¨‏“î ü¨ُھ ٌ‘¨}
SH_YEAR366_AND_SH_YEAR366 : ARRAY [1..12] OF
INTEGER=(00,01,00,01,00,00,-1,-1,-1,-2,-1,-1);
{ üَُّمُ ٌ‘¨ }
YEARS : ARRAY [1..12] OF
INTEGER=(00,01,-1,01,00,00,-1,-1,-1,-2,-1,-1);
VAR
Y1,M1,D1 : INTEGER;
SH_YEAR,M_YEAR : INTEGER;
GG : BOOLEAN;
MKABISEH,SKABISEH : BOOLEAN;
MKABISEHB,SKABISEHB : BOOLEAN;
MKABISEHN,SKABISEHN : BOOLEAN;
BEGIN
DWF:=DW;
GG:=TRUE;
SH_YEAR :=1374;
M_YEAR :=1996;
D1:=D-1;
M1:=M-1;
Y1:=Y-Y;
SH_YEAR :=SH_YEAR+(Y-M_YEAR);
MF:=10+M1;
YF:=SH_YEAR+Y1;
MKABISEH:=TESTM (Y);
SKABISEH:=TESTF (YF);
MKABISEHB:=TESTM (Y-1);
SKABISEHB:=TESTF (YF-1);
MKABISEHN:=TESTM (Y+1);
SKABISEHN:=TESTF (YF+1);
IF (NOT SKABISEH) AND (NOT MKABISEH) THEN
IF (SKABISEHN) AND (MKABISEHB) THEN
DF:=12+D1+(YEARS [M])
ELSE
DF:=11+D1+(YEARS [M])
ELSE
IF (SKABISEH) AND (MKABISEH) THEN
DF:=11+D1+(SH_YEAR366_AND_SH_YEAR366 [M])
ELSE
IF (SKABISEH) AND (MKABISEHN) THEN
DF:=11+D1+(SH_YEAR366 [M])
ELSE
IF (SKABISEH) AND (NOT MKABISEHN) THEN
DF:=12+D1+(SH_YEAR366 [M])
ELSE
IF (MKABISEH) AND (SKABISEHB) THEN
DF:=10+D1+(M_YEAR366 [M])
ELSE
IF (MKABISEH) AND (NOT SKABISEHB) THEN
DF:=11+D1+(M_YEAR366 [M]);
GG:=TRUE;
REPEAT
IF (DF>31) AND (MF<7) THEN
BEGIN
DF:=DF-31;
MF:=MF+1;
END
ELSE
IF (DF>30) AND ((MF>6) AND (MF<12)) THEN
BEGIN
DF:=DF-30;
MF:=MF+1;
END
ELSE
IF (DF>29) AND (MF=12) AND (NOT SKABISEH) THEN
BEGIN
DF:=DF-29;
MF:=MF+1;
END
ELSE
IF (DF>30) AND (MF=12) AND (SKABISEH) THEN
BEGIN
DF:=DF-30;
MF:=MF+1;
END
ELSE
GG:=FALSE;
IF (MF>12) THEN
BEGIN
MF:=MF-12;
YF:=YF+1;
GG:=TRUE;
END
ELSE
GG:=FALSE;
UNTIL GG=FALSE;
end;

end.