درخواست کامپوننت تاریخ شمسی برای دلفی 7

اگه به من میل بزنی برات میفرستم .

جناب این یک تابع است که به شرح زیر است:

اين يک تابع است
Function MiladyToShamsi(DTime:tdateTime):tdateTime;
var
YearEqual:array[0..2,0..2] of integer;
AddOneDay,AddFarDay:boolean;
AddTodays:byte;
Farday:byte;
ThisDay:word;
ThisMonth:word;
ThisYear:word;
YearDif1:Integer;
YearDif2:Integer;
TestRange1,testRange2,
FarsiRange1,FarsiRange2,P:Integer;
CurM,CurD:string;
sYear,sMonth,sDay:Variant;
Counter:Integer;
CurDay,CurMonth,CurYear:word;
Begin
CurM:='';
CurD:='';
YearEqual[1,1]:=1997;
YearEqual[1,2]:=1998;
YearEqual[2,1]:=1376;
YearEqual[2,2]:=1377;
DecodeDate(DTime,thisyear,thismonth,thisday);
YearDif1:=ThisYear-1997;
YearDif2:=ThisYear-1998;
Testrange1:=1996-(100*4);
Testrange2:=1996+(100*4);
FarsiRange1:=1375-(100*4);
FarsiRange2:=1375+(100*4);
AddOneDay:=false;
//Rem------------------------------
Counter:=TestRange1;
while TestRange2>=Counter do begin /////////////////////////
If thisYear=counter then begin
AddOneDay:=true;
break;
end;
If counter=TestRange2 then break;
counter:=counter+4
end;//while

If AddOneDay then
addtodays:=1
Else
AddTodays:=0;
//Rem---------------------------------/////////////////
If (((ThisMonth = 3) and (thisday<(20+AddtoDays)))
or ( ThisMonth<3)) then
YearDif1:=yearDif1-1;
//Rem------------
If (((thisYear mod 2)<>0) and
(((thismonth=3) and (thisday>(20-addTodays)))
or (thisMonth>4))) then
CurYear:=yearEqual[2,1]+YearDif1
else begin
CurYear:=YearEqual[2,1]+YearDif2;
Counter:=FarsiRange1;
while counter>FarsiRange2 do begin /////////////////////////
If CurYear=Counter then begin
AddFarDay:=true;
break;
end;
end;//while

If AddFarDay then
FarDay:=1 else Farday:=0;

If (((thismonth=3) and (thisday>20-(addToDays)+FarDay)) or (thismonth>3) ) then
CurYear:=CurYear+1;
end; //First If

If AddtoDays=1 then FarDay:=0;
//Rem---------------------------------
Case thismonth of
1:Begin
If thisday<(21-Farday) then begin
CurMonth:=10;
CurDay:=(ThisDay+10)+FarDay;
end else begin
CurMonth:=11;
CurDay:=(ThisDay-20)+FarDay;
end;
end;

2:Begin
If thisday<(20-Farday) then begin
CurMonth:=11;
CurDay:=(ThisDay+11)+FarDay;
end else begin
CurMonth:=12;
CurDay:=(ThisDay-19)+FarDay;
end;
End;

3:Begin
If thisday<(21-AddToDays) then begin
CurMonth:=12;
CurDay:=(ThisDay+9)+AddToDays+FarDay;
end else begin
CurMonth:=1;
CurDay:=(ThisDay-20)+AddToDays;
end;
End;

4:Begin
If thisday<(21-AddToDays) then begin
CurMonth:=1;
CurDay:=(ThisDay+11)+AddToDays;
end else begin
CurMonth:=2;
CurDay:=(ThisDay-20)+AddToDays;
end;
End;

5:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=2;
CurDay:=(ThisDay+10)+AddToDays;
end else begin
CurMonth:=3;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

6:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=3;
CurDay:=(ThisDay+10)+AddToDays;
end else begin
CurMonth:=4;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

7:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=4;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=5;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

8:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=5;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=6;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

9:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=6;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=7;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

10:Begin
If thisday<(23-AddToDays) then begin
CurMonth:=7;
CurDay:=(ThisDay+8)+AddToDays;
end else begin
CurMonth:=8;
CurDay:=(ThisDay-22)+AddToDays;
end;
End;

11:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=8;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=9;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

12:Begin
If thisday<(22-AddToDays) then begin
CurMonth:=9;
CurDay:=(ThisDay+9)+AddToDays;
end else begin
CurMonth:=10;
CurDay:=(ThisDay-21)+AddToDays;
end;
End;

end;//case
//Rem-----------------
CurM:=Trim(IntTostr(CurMonth));
CurD:=Trim(IntTostr(CurDay));
//Rem-----------------
If CurMonth<10 then
CurM:='0'+Trim(IntToStr(CurMonth));
If CurDay<10 then
CurD:='0'+Trim(IntTostr(CurDay));

Result:=EncodeDate(CurYear,CurMonth,CurDay);

end;
مثلا در فرم کريت بنويس:
label1.caption:=datetimetostr(MiladyToShamsi(date) );

موفق باشي
[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]
مجتبي رضائي از برازجان
:blush: :rolleye: :biggrin: :) :happy:

سلام

اقا ناصر اگه میشه برای من هم بفرست ممنونتم

[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

من کامپوننت تقویم فارسی رو تو وبلاگم گذاشتم
میتونی بری ببینی شاید به دردت خورد
[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

اقا قدير دستت درد نكنه بدردم خورد حسابي

ممنون

سلام
آقا مجتبي خيلي خوب بود ممنون.

دوستان عزيز يك كامپوننت با سورس براتون ميگذارم :
اين سورس خودم هست لطفا اگر به سورس آن تغييراتي داديد به من هم بدهيد. همين.

[ برای مشاهده لینک ، با نام کاربری خود وارد شوید یا ثبت نام کنید ]

سلام
اينو خودت نوشتي يا اينكه سورس رو فقط تبديل كردي به كمپننت؟

ميتوني از كامپ.ننت farsidate2 استفاده كني
هر كس مي خواد ايميل بزنه تا براش بفرستم

سلام آقا امير
اين كمپننت ساخته شده
توي يه تاپيك ديگه! بگردي پيدا مي كني