نمایش نتایج 1 تا 21 از 21

نام تاپیک: گردآوری شده ( تبدیل تاریخ میلادی و شمسی )

  1. #1

    Thumbs up گردآوری شده ( تبدیل تاریخ میلادی و شمسی )

    به نام خدا
    سلام
    با توجه به اینکه هر چند وقت یه بار سوالاتی در زمینه تبدیل تاریخ میلادی و شمسی مطرح میشه و پیشنهاد یکی از دوستان بر وجود یک تاپیک اطلاعیه ، فکر کردم بهتره این تاپیک را بذارم . کسانی که دنبال این راه حل ها می گرددند راحتتر بتونند آنها را پیدا کنند و اگه کسی راه حل جدیدی داشت در صورت تمایل در ادامه قرار بده
    البته من به عنوان یه کاربر عادی حق گذاشتن تاپیک اطلاعیه را ندارم. ولی توابعی که در این مورد تو برنامه نویس دیدم را به لینک مربوطه ذخیره کردم و به این ترتیب copyright رعایت میشه.
    من خودم بشخصه هیچ کامپوننت یا تابعی در این زمینه ننوشتم (یعنی بلد نبودم). و این توابعی که در ادامه اشاره میشه، لینک مستقیمشون را هم میذارم.
    ---------------------------------------------------------------------------------
    نقل قول نوشته شده توسط JavanSoft
    کامپوننت تقویم و سورس و مثال آنرا می توانید از سایت ModiranGroup..com بگیرید
    ---------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...ad.php?t=30635

    نقل قول نوشته شده توسط Touska
    کار کردن با هاش خیلی ساده هست. راستی مشکل تاریخ 4/31 و 6/31 رو نداره

    اسم توابع به صورت زیر هست :

    PrintDate :

    این تابع تاریخ رو به صورت : چهارشنبه 29 فرورین 1384

    PrintNormal :

    این تابع تاریخ رو به صورت : 1384/09/13

    DiffDate(fDate,sDate : String) : Integer

    این تابع اختلاف بین دو تا تاریخ را بر می گردونه

    XDateToStr(XDate : TDateTime) : ShortString

    این تابع تبدیل تاریخ به نوشتاری هست

    XStrToDate(XDate : ShortString) : TDateTime

    این تابع تبدیل نوشتاری به تاریخ هست

    XStrToDateDef(XDate : ShortString;Def : TDateTime) : TDateTime

    این تابع تبدیل نوشتاری به تاریخ با پیش فرض

    نسخه بعدیش رو هم می ذارم.
    --------------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...ad.php?t=45349
    نقل قول نوشته شده توسط Touska
    سلام

    گذشته این پست : http://www.barnamenevis.org/sh...ad.php?t=30635

    و آینده آن :

    تابع های

    Function PrintMonth(Dates : TDate) : ShortString

    این تایع یک تاریخ میلادی گرفته و سال و ماه شمس آن را بر می گرداند.

    Function PrintMonthf(Dates : ShortString) : ShortString

    این تابع یک تاریخ شمسی را گرفته و سال و ماه شمسی آن را بر می گرداند.

    Function XAddToDate(XDate : ShortString; XAdd : Integer) : ShortString

    این تابع یک تاریخ شمسی را گرفته و به آن XAdd روز اضافه می کند و شمسی بر می گرداند.

    Function XSubDate(XDate : ShortString; XSub : Integer) : ShortString

    این تابع یک تاریخ شمسی را گرفته و از آن XSub روز کم می کند و شمسی بر می گرداند.

    FAQ :

    برای استفاده از این تاریخ ها برای Sql چه در Select ها و چه در Like و چه در Between شما

    فیلدی از نوع char با Size 10 در دیتابیسی از نوع collation = Arabic_CI_AI می سازید و از آن

    برای تاریخ استفاده می کنید. مشکلی نخواهید داشت.

    برای استفاده از امکانات و توضیحات بیشتر به لینک گذشته این پست مراجعه کنید.


    همه برنامه نویس ها رو دوست دارم

    -----------------------------------------------------------------
    http://www.barnamenevis.org/sh...%E4#post238176

    نقل قول نوشته شده توسط Touska
    و نسخه جدید تر اون :

    Function XShamsiToMiladi(XDate : ShortString) : TDateTime

    تابع تبدیل شمسی به میلادی

    Function XMiladiTOShamsi(XDate : TDateTime) : ShortString

    تابع تبدیل میلادی به شمسی

    موفق باشید
    ----------------------------------------------------------------------
    https://barnamenevis.org/showth...056#post269056
    نقل قول نوشته شده توسط Touska
    نسخه جدید Persian.Dll

    و این قابلیت :

    Function XShortTOWide(XDate : ShortString) : ShortString;

    برای تبدیل تاریخ 1385/07/03 به دوشنبه 3 مهر 1385

    موفق باشید
    -------------------------------------------------------------------------


    __________________________________________________ ____________________
    http://www.barnamenevis.org/sh...3%26%231740%3B
    نقل قول نوشته شده توسط SalarSoft
    سلام بر همه
    چندی پیش در بحث با یکی از برنامه نویسان در یه تاپیکی در مورد مشکل با تاریخ فارسی و توابعی که من نوشتم , من رو بر آن کرد که توابع خودم رو کامل کنم.

    تعریف نباشه :oops: ولی سعی کردم که در این یونیت که آدرسش در زیر اومده توابع تغییر یافته دلفی برای کار با تاریخ فارسی رو برای استفاده همگان بذارم.
    از جمله این تابع ها MiladyToShamsi و FarEncodeDate و FarDecodeDate و farFormatDateTime و farStrToDate و farDateToStr و... است.

    لینک دانلود: http://www.salarsoft.somee.com/downl....htm#farsidate
    لینک مستقیم دانلود: http://salarsoft.somee.com/downloads/free/farsidate.zip
    لینک توضیحات: http://www.salarsoft.somee.com/magal..._date_help.htm

    در ضمن قبل از استفاده از این یونیت نحوه استفاده شو حتما بخونید.

    نحوه استفاده:
    در استفاده از این توابع نیازی به ایجاد کلاس TFarDate نمی باشد. بلکه باید آن را مستقیما به کار برد: مثلا
    TFarDate.miladyToShamsi(Now)


    برای اینکه توابع نتیجه درست را بدهند, اول باید از یکی از توابع (FarEncodeDate یا MiladyToShamsi یا MiladyToShamsiInt یا farStrToDate یا farStrToDateDef) استفاده کنید.
    سپس می توانید از بقیه توابع استفاده کنید.
    موفق باشید. :lol:
    --------------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/showthread.php?t=5959
    نقل قول نوشته شده توسط programersa
    سلام
    این تابع شمسی به میلادی:

    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;

    موفق باشید .

    --------------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED

    نقل قول نوشته شده توسط mehdi_moosavi


    // var Sal,Mah,Rooz:Word; begin
    // SolarDecodeDate(Date,Sal,Mah,Rooz);
    // StatusBar1.Panels[1].Text:=RozName+' '+IntToStr(Sal)+'/'+IntToStr(Mah)+'/'+IntToStr(Rooz);
    // Edit2.Text:=IntToStr(Sal-1300)+'/'+IntToStr(Mah)+'/'+IntToStr(Rooz);



    unit SolarUnit;

    interface
    uses SysUtils;

    type
    TDateKind = (dkSolar, dkGregorian);

    function IsLeapYear(DateKind: TDateKind; Year: Word): Boolean;
    function IsDateValid(DateKind: TDateKind; Year, Month, Day: Word): Boolean;
    function DateOfDay(DateKind: TDateKind; Days, Year: Word; var Month, Day: Word): Boolean;
    function GregorianToSolar(var Year, Month, Day: Word): Boolean;
    function SolarToGregorian(var Year, Month, Day: Word): Boolean;
    function DaysOfMonth(DateKind: TDateKind; Year, Month: Word): Word;
    function DaysToDate(DateKind: TDateKind; Year, Month, Day: Word): Word;
    procedure SolarDecodeDate(Date: TDateTime; var Year, Month, Day: Word);
    function SolarEncodeDate(Year, Month, Day: Word): TDateTime;


    implementation

    uses DataEntry, DataMadule, Functoins;






    const
    LeapMonth: array[TDateKind] of Byte =
    (12 {Esfand}, 2 {February});
    DaysOfMonths: array[TDateKind, 1..12] of Byte = (
    ( 31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29 )
    { Far, Ord, Kho, Tir, Mor, Sha, Meh, Aba, Aza, Day, Bah,^Esf },
    ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 )
    { Jan,^Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec });
    DaysToMonth: array[TDateKind, 1..13] of Word = (
    ( 0, 31, 62, 93, 124, 155, 186, 216, 246, 276, 306, 336, 365 )
    { Far, Ord, Kho, Tir, Mor, Sha, Meh, Aba, Aza, Day, Bah,^Esf, *** },
    ( 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 )
    { Jan,^Feb, Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec, *** });


    function IsLeapYear(DateKind: TDateKind; Year: Word): Boolean;
    begin
    if DateKind = dkSolar then
    Result := ((((LongInt(Year) + 38) * 31) mod 128) <= 30)
    else
    Result := ((Year mod 4) = 0) and (((Year mod 100) <> 0) or ((Year mod 400) = 0));
    end;

    function DaysOfMonth(DateKind: TDateKind; Year, Month: Word): Word;
    begin
    if (Year <> 0) and (Month in [1..12]) then
    begin
    Result := DaysOfMonths[DateKind, Month];
    if (Month = LeapMonth[DateKind]) and IsLeapYear(DateKind, Year) then
    Inc(Result);
    end
    else
    Result := 0;
    end;

    function IsDateValid(DateKind: TDateKind; Year, Month, Day: Word): Boolean;
    begin
    Result := (Year <> 0) and (Month >= 1) and (Month <= 12) and
    (Day >= 1) and (Day <= DaysOfMonth(DateKind, Year, Month));
    end;

    function DaysToDate(DateKind: TDateKind; Year, Month, Day: Word): Word;
    begin
    if IsDateValid(DateKind, Year, Month, Day) then
    begin
    Result := DaysToMonth[DateKind, Month] + Day;
    if (Month > LeapMonth[DateKind]) and IsLeapYear(DateKind, Year) then
    Inc(Result);
    end
    else
    Result := 0;
    end;

    function DateOfDay(DateKind: TDateKind; Days, Year: Word; var Month, Day: Word): Boolean;
    var
    LeapDay, m: Integer;
    begin
    LeapDay := 0;
    Month := 0;
    Day := 0;
    for m := 2 to 13 do
    begin
    if (m > LeapMonth[DateKind]) and IsLeapYear(DateKind, Year) then
    LeapDay := 1;
    if Days <= (DaysToMonth[DateKind, m] + LeapDay) then
    begin
    Month := m - 1;
    if Month <= LeapMonth[DateKind] then LeapDay := 0;
    Day := Days - (DaysToMonth[DateKind, Month] + LeapDay);
    Break;
    end;
    end;
    Result := IsDateValid(DateKind, Year, Month, Day);
    end;

    function GregorianToSolar(var Year, Month, Day: Word): Boolean;
    var
    LeapDay, Days: Integer;
    PrevGregorianLeap: Boolean;
    begin
    if IsDateValid(dkGregorian, Year, Month, Day) then
    begin
    PrevGregorianLeap := IsLeapYear(dkGregorian, Year-1);
    Days := DaysToDate(dkGregorian, Year, Month, Day);
    Dec(Year, 622);
    if IsLeapYear(dkSolar, Year) then
    LeapDay := 1
    else
    LeapDay := 0;
    if PrevGregorianLeap and (LeapDay = 1) then
    Inc(Days, 287)
    else
    Inc(Days, 286);
    if Days > (365 + LeapDay) then
    begin
    Inc(Year);
    Dec(Days, 365 + LeapDay);
    end;
    Result := DateOfDay(dkSolar, Days, Year, Month, Day);
    end
    else
    Result := False;
    end;

    function SolarToGregorian(var Year, Month, Day: Word): Boolean;
    var
    LeapDay, Days: Integer;
    PrevSolarLeap: Boolean;
    begin
    if IsDateValid(dkSolar, Year, Month, Day) then
    begin
    PrevSolarLeap := IsLeapYear(dkSolar, Year-1);
    Days := DaysToDate(dkSolar, Year, Month, Day);
    Inc(Year, 621);
    if IsLeapYear(dkGregorian, Year) then
    LeapDay := 1
    else
    LeapDay := 0;
    if PrevSolarLeap and (LeapDay = 1) then
    Inc(Days, 80)
    else
    Inc(Days, 79);
    if Days > (365 + LeapDay) then
    begin
    Inc(Year);
    Dec(Days, 365 + LeapDay);
    end;
    Result := DateOfDay(dkGregorian, Days, Year, Month, Day);
    end
    else
    Result := False;
    end;

    function SolarEncodeDate(Year, Month, Day: Word): TDateTime;
    begin
    if SolarToGregorian(Year, Month, Day) then
    Result := EncodeDate(Year, Month, Day)
    else
    Result := 0;
    end;

    procedure SolarDecodeDate(Date: TDateTime; var Year, Month, Day: Word);
    begin
    DecodeDate(Date, Year, Month, Day);
    GregorianToSolar(Year, Month, Day);
    end;

    end.


    --------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED

    نقل قول نوشته شده توسط H.Yousefi
    شما برای تبدیل راحت این تاریخ می توانید از کامپوننت HijriDate استفاده کنید تا سریعت تاریخ را برای شما تبدیل و مشخص کند. جهت دریافت این کامپوننت میتوانید با آدرس h.yousefi@aeghboloori.com با من تماس بگیرید.
    ------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...ad.php?t=35810

    نقل قول نوشته شده توسط Majid_ag
    این کامپوننت رو خودم نوشتم ،خیلی خوبه!!!!!!!!!!!
    http://www.megaupload.com/?d=3YIC4YT4
    --------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...ad.php?t=35811

    نقل قول نوشته شده توسط saniak_robot
    یه کامپوننت واست گذاشتم اینجا هم میذارم
    --------------------------------------------------------------------------------------------
    ادامه دارد .....




  2. #2

    Thumbs up

    قسمت دوم:

    --------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...ad.php?t=35811

    نقل قول نوشته شده توسط مجید جنگی
    تابع ذیل را اجرا کنید حتما جواب می گیرید.


    var
    G_M,G_D,G_Y,g_cur_date,date1,da_myear,da_mmonth,da _mday:String;
    a,da_cont,da_acc,y,m,d,da_sh1,da_sh2,da_sh3,da_sh4 ,da_sh5,da_sh6,da_me1,da_me3,da_me5,da_me7:integer ;
    da_me8,da_me10,da_me12,da_sh7,da_sh8,da_sh9,da_sh1 0,da_sh11,da_me6,da_me9,da_me11,da_me4:integer;
    da_sh12,da_me2,da_syear,da_smonth,da_sday:integer;

    begin
    da_cont:=1; da_acc:=0; da_sh1:=31; da_sh2:=31; da_sh3:=31; da_sh4:=31; da_sh5:=31; da_sh6:=31;
    da_me1:=31; da_me3:=31; da_me5:=31; da_me7:=31; da_me8:=31; da_me10:=31;da_me12:=31; da_sh7:=30;
    da_sh8:=30; da_sh9:=30; da_sh10:=30; da_sh11:=30;da_me4:=30; da_me6:=30; da_me9:=30; da_me11:=30;
    da_sh12:=29; da_me2:=28; da_syear:=0; da_smonth:=0;
    da_sday:=0; da_myear:='0'; da_mmonth:='0'; da_mday:='0';
    date1:=DateToStr(date);
    da_mday:=date1[9]+date1[10];
    da_mmonth:=date1[6]+date1[7];
    da_myear:=date1[1]+date1[2]+date1[3]+date1[4];
    If ((da_mmonth = '03') And (da_mday < '21')) Or (da_mmonth < '03') Then
    try
    da_syear := StrToInt(da_myear) - 622;
    Except
    on EConvertError do
    begin
    FormMain.MaskEditDate.ReadOnly:=False;
    Exit;
    end;
    end
    Else
    da_syear := StrToInt(da_myear) - 621;
    If (StrToInt(da_myear) Mod 4) <> 0 Then
    begin
    da_sh12 := 30;
    da_me2 := 29;
    End;
    If da_mmonth = '02' Then
    da_acc := da_acc + da_me1
    Else If da_mmonth = '03' Then
    da_acc := da_acc + da_me1 + da_me2
    Else If da_mmonth = '04' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3
    Else If da_mmonth = '05' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4
    Else If da_mmonth = '06' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 +da_me5
    Else If da_mmonth = '07' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 + da_me5 + da_me6
    Else If da_mmonth = '08' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 + da_me5 + da_me6 + da_me7
    Else If da_mmonth = '09' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 + da_me5 + da_me6 + da_me7 + da_me8
    Else If da_mmonth = '10' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 + da_me5 + da_me6 + da_me7 + da_me8 + da_me9
    Else If da_mmonth = '11' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 + da_me5 + da_me6 + da_me7 + da_me8 + da_me9 + da_me10
    Else If da_mmonth = '12' Then
    da_acc := da_acc + da_me1 + da_me2 + da_me3 + da_me4 + da_me5 + da_me6 + da_me7 + da_me8 + da_me9 + da_me10 + da_me11;
    da_acc := da_acc + StrToInt(da_mday);
    If ((da_mmonth = '03') And (da_mday < '21')) Or (da_mmonth < '03') Then
    da_acc := da_acc + 286
    Else
    da_acc := da_acc - (da_sh11 + da_sh12 + 20);
    da_cont := 1;
    If da_acc <= da_sh1 Then
    begin
    da_smonth := 1;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1) <= da_sh2 Then
    begin
    da_acc := da_acc - da_sh1;
    da_smonth := 2;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2) <= da_sh3 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2;
    da_smonth := 3;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3) <= da_sh4 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3;
    da_smonth := 4;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4) <= da_sh5 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4;
    da_smonth := 5;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5) <=da_sh6 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5;
    da_smonth := 6;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6) <= da_sh7 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6;
    da_smonth := 7;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7) <= da_sh8 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7;
    da_smonth := 8;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8) <= da_sh9 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8;
    da_smonth := 9;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8 - da_sh9) <= da_sh10 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8 - da_sh9;
    da_smonth := 10;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8 - da_sh9 - da_sh10) <= da_sh11 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8 - da_sh9 - da_sh10;
    da_smonth := 11;
    da_sday := da_acc;
    end
    Else If (da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8 - da_sh9 - da_sh10 - da_sh11) <= da_sh12 Then
    begin
    da_acc := da_acc - da_sh1 - da_sh2 - da_sh3 - da_sh4 - da_sh5 - da_sh6 - da_sh7 - da_sh8 - da_sh9 - da_sh10 - da_sh11;
    da_smonth := 12;
    da_sday := da_acc;
    end;
    If (da_mmonth = '03') And (da_mday = '20') Then
    begin
    a := da_syear + 2;
    If (da_cont Mod 4) = 0 Then
    da_sday := 30
    Else
    da_sday := 29;
    end;
    y := da_syear - 1300;
    m := da_smonth;
    d := da_sday;
    if (da_smonth<10) and (da_sday<10) then
    MaskEditDate.Text:=IntToStr(y)+'0'+IntToStr(m)+'0' +IntToStr(d)
    else
    if (da_smonth<10) then
    MaskEditDate.Text:=IntToStr(y)+'0'+IntToStr(m)+Int ToStr(d)
    else
    if (da_sday<10) then
    MaskEditDate.Text:=IntToStr(y)+IntToStr(m)+'0'+Int ToStr(d)
    else
    MaskEditDate.Text:=IntToStr(y)+IntToStr(m)+IntToSt r(d);
    End;
    ---------------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED


    function shamsi(tt:tdatetime):string;
    var
    str,y,m,d:string;
    yi,mi,di:integer;
    begin
    str:=datetostr(tt);
    y:=copy(str,1,4);
    m:=copy(str,6,2);
    d:=copy(str,9,2);
    yi:=strtoint(y);
    mi:=strtoint(m);
    di:=strtoint(d);
    if (yi mod 4=0) then
    if mi>2 then
    begin
    tt:=tt+1;
    str:=datetostr(tt);
    y:=copy(str,1,4);
    m:=copy(str,6,2);
    d:=copy(str,9,2);
    yi:=strtoint(y);
    mi:=strtoint(m);
    di:=strtoint(d);
    end;
    if ((mi<3) or ((mi=3) and (di<21))) then
    begin
    yi:=yi-622;
    end
    else
    begin
    yi:=yi-621;
    end;
    case mi of
    1:

    if di<21 then
    begin
    mi:=10;
    di:=di+10;
    end
    else
    begin
    mi:=11;
    di:=di+10;
    end;

    2:
    if di<20 then
    begin
    mi:=11;
    di:=di+11;
    end
    else
    begin
    mi:=12;
    di:=di-19;
    end;
    3:
    if di<21 then
    begin
    mi:=12;
    di:=di+9;
    end
    else
    begin
    mi:=1;
    di:=di-20;
    end;
    4:
    if di<21 then
    begin
    mi:=1;
    di:=di+11;
    end
    else
    begin
    mi:=2;
    di:=di-20;
    end;
    5:
    if di<22 then
    begin
    mi:=mi-3;
    di:=di+10;
    end
    else
    begin
    mi:=mi-2;
    di:=di-21;
    end;
    6:
    if di<22 then
    begin
    mi:=mi-3;
    di:=di+10;
    end
    else
    begin
    mi:=mi-2;
    di:=di-21;
    end;
    7:
    if di<23 then
    begin
    mi:=mi-3;
    di:=di+9;
    end
    else
    begin
    mi:=mi-2;
    di:=di-22;
    end;
    8:
    if di<23 then
    begin
    mi:=mi-3;
    di:=di+9;
    end
    else
    begin
    mi:=mi-2;
    di:=di-22;
    end;
    9:
    if di<23 then
    begin
    mi:=mi-3;
    di:=di+9;
    end
    else
    begin
    mi:=mi-2;
    di:=di-22;
    end;
    10:
    if di<23 then
    begin
    mi:=7;
    di:=di+8;
    end
    else
    begin
    mi:=8;
    di:=di-22;
    end;
    11:
    if di<22 then
    begin
    mi:=mi-3;
    di:=di+9;
    end
    else
    begin
    mi:=mi-2;
    di:=di-21;
    end;
    12:
    if di<22 then
    begin
    mi:=mi-3;
    di:=di+9;
    end
    else
    begin
    mi:=mi-2;
    di:=di-21;
    end;
    end;
    y:=inttostr(yi);
    m:=inttostr(mi);

    if (length(m)=1) then
    m:='0'+m;
    d:=inttostr(di);
    if length(d)=1 then
    d:='0'+d;
    shamsi:=y+'/'+m+'/'+d
    end;



    ---------------------------------------------------------------------------------------------------------
    http://www.oxinsoft.com/shamsidll/about.htm
    شـمـســی DLL نگارش 2
    تاریخ شمسی را به برنامه‌های خود اضافه کنید

    --------------------------------------------------------------------------------------------------------

    http://www.barnamenevis.org/sh...F%26%231740%3B

    http://www.barnamenevis.org/sh...ad.php?t=31154

    نقل قول نوشته شده توسط (امید)
    از آقای بابک یعقوبی ( برداشت شده از barnamenevis.com )

    ــــــــــــــــــــــــــــــــــــــــــــــــــ ــــــــــــــــــــــــــــــــــــــــــــــــــ ـــــــــــــــــــــــــــــــــــــــــــ


    unit UDate;

    interface

    type

    t_date = record
    y, m, d : word;
    end;

    procedure ShToM(var sh, m : t_date);
    procedure MToSh(var m, sh : t_date);

    implementation

    uses sysUtils;

    type
    tt_date = record
    y, m, d : longint;
    end;

    Const
    MKMONTH = 2;
    SHKMONTH = 12;

    SHRYEAR = 1358;
    SHRMONTH = 10;
    SHRDAY = 11;

    MRYEAR = 1980;
    MRMONTH = 1;
    MRDAY = 1;

    _SHRYEAR = 1358;
    _SHRMONTH = 1;
    _SHRDAY = 1;

    _MRYEAR = 1979;
    _MRMONTH = 3;
    _MRDAY = 21;

    sh_month : array [1..12] of integer =
    (31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 29);
    sh_k_month : array [1..12] of integer =
    (31, 31, 31, 31, 31, 31, 30, 30, 30, 30, 30, 30);
    m_month : array [1..12] of integer =
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
    m_k_month : array [1..12] of integer =
    (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);

    MaxKYears = 63;
    sh_k_years : array [1.. MaxKYears] of integer =
    (1197, 1201, 1205, 1210, 1214, 1218, 1222, 1226,
    1230, 1234, 1238, 1243, 1247, 1251, 1255, 1259,
    1263, 1267, 1271, 1276, 1280, 1284, 1288, 1292,
    1296, 1300, 1304, 1309, 1313, 1317, 1321, 1325,
    1329, 1333, 1337, 1342, 1346, 1350, 1354, 1358,
    1362, 1366, 1370, 1375, 1379, 1383, 1387, 1391,
    1395, 1399, 1403, 1408, 1412, 1416, 1420, 1424,
    1428, 1432, 1436, 1441, 1445, 1449, 1453);

    function sh_is_k(y : integer) : boolean;
    var
    i : integer;
    begin
    if y &lt; 100 then y := y + 1300;
    sh_is_k := false;
    for i := 1 to MaxKYears do
    if sh_k_years[i] = y then begin
    sh_is_k := true;
    exit;
    end;
    end;

    function m_elapsed(m : t_date) : longint;
    var
    mt, rt : TDateTime;
    el : real;
    begin
    rt := EncodeDate(MRYEAR, MRMONTH, MRDAY);
    mt := EncodeDate(m.y, m.m, m.d);
    el := mt - rt;
    m_elapsed := trunc(el);
    end;

    function sh_elapsed(sh : t_date) : longint;
    var
    el, i : longint;
    sh_k : boolean;
    begin
    el := 0;
    sh_k := sh_is_k(sh.y);

    // sh_elapsed := 0;

    if sh.y &lt; 100 then sh.y := sh.y + 1300;
    if sh.y &lt; _SHRYEAR then begin
    el := (longint(sh.y+1) - _SHRYEAR) * 365;
    for i := _SHRYEAR downto sh.y+1 do
    if sh_is_k(i) then dec(el);
    for i := 12 downto sh.m+1 do
    if sh_k then
    el := el - sh_k_month[i]
    else
    el := el - sh_month[i];
    if sh_k then el := el - (sh_k_month[sh.m] - sh.d)
    else el := el - (sh_month[sh.m] - sh.d);
    end else begin
    if sh.y > _SHRYEAR then
    el := el + (sh.y - _SHRYEAR) * 365;
    for i := _SHRYEAR to sh.y-1 do
    if sh_is_k(i) then inc(el);
    for i := 1 to sh.m-1 do
    if sh_k then
    el := el + sh_k_month[i]
    else
    el := el + sh_month[i];
    el := el + sh.d - _SHRDAY;
    end;
    sh_elapsed := el;
    end;

    procedure sh_add(var sht : t_date; el : longint);
    var
    mt, yt : longint;
    sh : tt_date;
    begin
    if el = 0 then exit;
    sh.y := sht.y;
    sh.m := sht.m;
    sh.d := sht.d;
    if el &lt; 0 then begin
    while abs(el) >= 366 do begin
    if (sh_is_k(sh.y) and (sh.m >= SHKMONTH)) or
    (sh_is_k(sh.y-1) and (sh.m &lt; SHKMONTH))
    then
    el := el + 366
    else
    el := el + 365;
    dec(sh.y);
    end;
    yt := sh.y;
    mt := sh.m - 1;
    if mt &lt; 1 then begin
    mt := 12;
    dec(yt);
    end;
    while (sh_is_k(yt) and (abs(el) > sh_k_month[mt])) or
    (not sh_is_k(yt) and (abs(el) > sh_month[mt])) do
    begin
    if(sh_is_k(yt)) then
    el := el + sh_k_month[mt]
    else
    el := el + sh_month[mt];
    dec(sh.m);
    while sh.m &lt; 1 do begin
    sh.m := sh.m + 12;
    dec(sh.y);
    end;
    yt := sh.y;
    mt := sh.m - 1;
    if mt &lt; 1 then begin
    mt := 12;
    dec(yt);
    end;
    end;
    sh.d := sh.d + el;
    while (sh.d &lt;= 0) do
    begin
    yt := sh.y;
    mt := sh.m - 1;
    if mt &lt; 1 then begin
    mt := 12;
    dec(yt);
    end;
    if(sh_is_k(yt)) then
    sh.d := sh.d + sh_k_month[mt]
    else
    sh.d := sh.d + sh_month[mt];
    dec(sh.m);
    while sh.m &lt; 1 do begin
    sh.m := sh.m + 12;
    dec(sh.y);
    end;
    end;
    end else begin
    while el >= 366 do begin
    if (sh_is_k(sh.y) and (sh.m &lt;= SHKMONTH)) or
    (sh_is_k(sh.y+1) and (sh.m > SHKMONTH))
    then
    el := el - 366
    else
    el := el - 365;
    inc(sh.y);
    end;
    while (sh_is_k(sh.y) and (el > sh_k_month[sh.m])) or
    (not sh_is_k(sh.y) and (el > sh_month[sh.m])) do
    begin
    if(sh_is_k(sh.y)) then
    el := el - sh_k_month[sh.m]
    else
    el := el - sh_month[sh.m];
    inc(sh.m);
    while sh.m > 12 do begin
    sh.m := sh.m - 12;
    inc(sh.y);
    end;
    end;
    sh.d := sh.d + el;
    while (sh_is_k(sh.y) and (sh.d > sh_k_month[sh.m])) or
    (not sh_is_k(sh.y) and (sh.d > sh_month[sh.m])) do
    begin
    if(sh_is_k(sh.y)) then
    sh.d := sh.d - sh_k_month[sh.m]
    else
    sh.d := sh.d - sh_month[sh.m];
    inc(sh.m);
    while sh.m > 12 do begin
    sh.m := sh.m - 12;
    inc(sh.y);
    end;
    end;
    end;
    sht.y := sh.y;
    sht.m := sh.m;
    sht.d := sh.d;
    end;

    procedure m_add(var m : t_date; el : longint);
    var
    mt : TDateTime;
    begin
    mt := EncodeDate(m.y, m.m, m.d);
    mt := mt + el;
    DecodeDate(mt, m.y, m.m, m.d);
    end;

    procedure MToSh(var m, sh : t_date);
    var
    el : longint;
    begin
    { 1358/10/11 = 1980/1/1 }
    el := m_elapsed(m);
    sh.y := SHRYEAR;
    sh.m := SHRMONTH;
    sh.d := SHRDAY;
    sh_add(sh, el);
    end;

    procedure ShToM(var sh, m : t_date);
    var
    el : longint;
    begin
    { 1358/1/1 = 1979/3/21 }
    el := sh_elapsed(sh);
    m.y := _MRYEAR;
    m.m := _MRMONTH;
    m.d := _MRDAY;
    m_add(m, el);
    end;
    end.


    بابک یعقوبی
    -------------------------------------------------------------------------------------------------

    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED

    نقل قول نوشته شده توسط یعقوب
    با سلام.
    یک یونیت بسیارعالی برای تبدیل تاریخ میلادی به شمسی و به عکس. همراه با توابع به درد بخور دیگر در مورد تاریخ.
    البته بگم که این یونیت توسط آقای کامبیزخجسته از سایت www.delphiarea.com نوشته شده.
    توضیحات در مورد توابع این یونیت همراه با مثال دراون اومده.
    مثالی که با این یونیت آورده شده هم مثال جالبی است.
    استفاده کنید و دعاشو به جون نویسنده اش بکنید.

    امیدوارم استفاده کنید و لذت ببرید.
    ---------------------------------------------------------------------------------------------------

    http://www.barnamenevis.org/sh...A+%E1%C7%D2%E3

    نقل قول نوشته شده توسط mtajik
    جهت download کنترل فوق به آدرس زیر مراجعه کنید:

    http://www.vbiran.com/fardate.html

    -------------------------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...ad.php?t=38103

    نقل قول نوشته شده توسط babak_delphi
    با سلام خدمت دوستان
    با توجه به اینکه برنامه نویسای زیادی در مورد نحوه تبدیل تاریخ میلادی به شمسی سوال می پرسند من ، این تابع رو به همراه 2 تابع دیگه که یکی برای نمایش عدد بصورت فرمت شده (3 رقم 3رقم از راست) و یکی واسه اینکه 1 edit فقط عدد بگیره ، توی یک unit قرار دادم و کدش رو اینجا گذاشتم.
    نحوه استفاده اونها رو هم با 1 مثال توضیح دادم :





    unit Util;

    interface
    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, StdCtrls, Tlhelp32;
    type
    function NumberToCurrency(Num: string):string;
    Function IsNum(ch : char) : char;
    Function MiladiToHejri(GregorianDate : String;DateType : Integer) : String;
    implementation

    Function IsNum(ch : char) : char;
    begin
    Try
    if Pos(ch,#8#13'1234567890') = 0 then
    ch := #0;
    Result := ch;
    Except
    Application.MessageBox(' !!! یک اشکال ناشناخته در روند انجام کار پیش آمده است ','ERROR',MB_OK + MB_ICONERROR);
    end;
    end;

    Function MiladiToHejri(GregorianDate : String;DateType : Integer) : String;
    var
    jmm, jdd : string;
    g_days_in_month, j_days_in_month : array[0..11] of Integer;
    HijriMonths : array[1..12] of String;
    g_day_no, j_day_no, jy, jm, gy, gm : Longint;
    j_np, i, jd, GD : Integer;
    flag : Boolean;
    begin
    Try
    flag := true;
    g_days_in_month[0] := 31;
    g_days_in_month[1] := 28;
    g_days_in_month[2] := 31;
    g_days_in_month[3] := 30;
    g_days_in_month[4] := 31;
    g_days_in_month[5] := 30;
    g_days_in_month[6] := 31;
    g_days_in_month[7] := 31;
    g_days_in_month[8] := 30;
    g_days_in_month[9] := 31;
    g_days_in_month[10] := 30;
    g_days_in_month[11] := 31;
    j_days_in_month[0] := 31;
    j_days_in_month[1] := 31;
    j_days_in_month[2] := 31;
    j_days_in_month[3] := 31;
    j_days_in_month[4] := 31;
    j_days_in_month[5] := 31;
    j_days_in_month[6] := 30;
    j_days_in_month[7] := 30;
    j_days_in_month[8] := 30;
    j_days_in_month[9] := 30;
    j_days_in_month[10] := 30;
    j_days_in_month[11] := 29;
    If GregorianDate = Null Then Exit;
    gy := (StrToInt(FormatDateTime('yyyy', StrToDate(GregorianDate)))) - 1600 ;
    gm := (StrToInt(FormatDateTime('mm', StrToDate(GregorianDate)))) - 1 ;
    GD := (StrToInt(FormatDateTime('dd', StrToDate(GregorianDate)))) - 1 ;
    g_day_no := 365 * gy + (gy + 3) div 4 - (gy + 99) div 100 + ( gy + 399) div 400;
    i := 0;
    While i < gm do
    begin
    g_day_no := g_day_no + g_days_in_month[i];
    i := i + 1;
    end;
    If (gm > 1) And (((gy Mod 4 = 0) And (gy Mod 100 <> 0)) Or (gy Mod 400 = 0)) Then
    g_day_no := g_day_no + 1;
    g_day_no := g_day_no + GD;
    j_day_no := g_day_no - 79;
    j_np := j_day_no div 12053;
    j_day_no := j_day_no Mod 12053;
    jy := 979 + 33 * j_np + 4 * (j_day_no div 1461);
    j_day_no := j_day_no Mod 1461;
    If (j_day_no >= 366) Then
    begin
    jy := jy + (j_day_no - 1) div 365;
    j_day_no := (j_day_no - 1) Mod 365;
    End;
    i := 0;
    While (j_day_no >= j_days_in_month[i]) and flag do
    begin
    j_day_no := j_day_no - j_days_in_month[i];
    i := i + 1;
    If i > 12 Then
    begin
    i := 11;
    j_day_no := 29;
    flag := False;
    End;
    end;
    jm := i + 1;
    jd := j_day_no + 1;
    jmm := IntToStr(jm);
    jdd := IntToStr(jd);
    If (Length(jmm) = 1) then
    jmm := '0' + jmm
    else
    jmm := jmm;
    if (Length(jdd) = 1) then
    jdd := '0' + jdd
    else
    jdd := jdd;
    HijriMonths[1] := 'فروردین';
    HijriMonths[2] := 'اردیبهشت';
    HijriMonths[3] := 'خرداد';
    HijriMonths[4] := 'تیر';
    HijriMonths[5] := 'مرداد';
    HijriMonths[6] := 'شهریور';
    HijriMonths[7] := 'مهر';
    HijriMonths[8] := 'آبان';
    HijriMonths[9] := 'آذر';
    HijriMonths[10] := 'دی';
    HijriMonths[11] := 'بهمن';
    HijriMonths[12] := 'اسفند';
    if jmm = '13' then
    begin
    jmm := '12';
    jdd := '30';
    end;
    Case DateType of
    0:
    MiladiToHejri := IntToStr(jy) + '/' + jmm + '/' + jdd;
    1:
    MiladiToHejri := IntToStr(strtoint(jdd)) + ' ' + HijriMonths[StrToInt(jmm)] + ' ' + IntToStr(jy);
    End;
    except
    MiladiToHejri := 'تاریخ وارد شده، اشتباه می باشد .';
    end;
    End;
    function NumberToCurrency(Num: string):string;
    var
    s1,res : string;
    int1 : integer;
    begin
    s1 := Copy(str,1,1);
    int1 := StrToInt(s1);
    res := ar3[int1 - 1];
    Result := res;
    end;

    end.




    برای استفاده کافیست این unit رو هر جا که خواستید uses کنید و توابع رو بصورت زیر استفاده کنید:
    Label1.Caption := NumberToCurrency(Edit1.Text);

    برای اینکه Edit فقط عدد بگیره این کد رو در OnKeyPress ادیت بنویسید :
    Key := IsNum(Key);

    Edit1.Text := MiladiToHejri(DateToStr(Now),0)

    م.فق باشید.
    -----------------------------------------------------------------------------------------------

    و چند تا لینک دیگه:

    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED

    http://www.barnamenevis.org/viewtopic.php?t=28979


    www.farsiComponents.com


    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED


    http://www.barnamenevis.org/sh...t=%D4%E3%D3%ED

    -----------------------------------------------------------------------------------------

    با تشکر از تمامی دوستان که این توابع یا کامپوننت ها در اختیار دیگران قرار دادند.

    و آرزوی موفقیت و سریلندی همه شما!

    (امیدوارم تو کپی کردن لینکها اشتباهی جابجا اونا را نگذاشته باشم. اگه موردی بود تذکر بدید)
    آخرین ویرایش به وسیله oghab : سه شنبه 18 بهمن 1384 در 15:50 عصر

  3. #3
    کاربر دائمی آواتار babak869
    تاریخ عضویت
    اسفند 1383
    محل زندگی
    کرمانشاه
    پست
    1,251
    عقاب عزیز دستت درد نکنه
    از ابداعی که به خرج دادی ممنون واقعا جای تحسین داره اما فکر کنم که لینک فایل دی ال ال توسکای عزیز رو فراموش کردی بزاری .چون اون Dll هم خیلی جالبه و واقعا کارآیی بالایی داره
    http://www.barnamenevis.org/sh...3%26%231740%3B
    امیدوارم که همگی موفق باشید

  4. #4
    کاربر دائمی آواتار MNosouhi
    تاریخ عضویت
    مرداد 1384
    محل زندگی
    اصفهان
    پست
    883
    من هم تشکر میکنم.لطفا این تاپیک تبدیل به اطلاعیه بشه.
    ممنون

  5. #5
    کاربر دائمی
    تاریخ عضویت
    مهر 1384
    محل زندگی
    Iran e sarfaraz
    پست
    150
    با تشکر از دوستان از آقای کرامتی یا دوستان دیگر که میتوانند خواهشمندیم این تاپیک را به اطلاعیه تبدیل کنند

  6. #6
    نقل قول نوشته شده توسط babak869
    عقاب عزیز دستت درد نکنه
    از ابداعی که به خرج دادی ممنون واقعا جای تحسین داره اما فکر کنم که لینک فایل دی ال ال توسکای عزیز رو فراموش کردی بزاری .چون اون Dll هم خیلی جالبه و واقعا کارآیی بالایی داره
    http://www.barnamenevis.org/sh...3%26%231740%3B
    امیدوارم که همگی موفق باشید
    خواهش می کنم. و از لطف همگی ممنونم
    در ضمن dll جناب touska دومین موردی هست که اشاره شده!
    عید غدیر مبارک
    موفق باشید

  7. #7
    کاربر دائمی آواتار unique1984
    تاریخ عضویت
    دی 1384
    محل زندگی
    Newjef Land
    سن
    37
    پست
    221
    من یه کامپوننت آماده در این زمینه دارم هر کی خواست بهم میل بزنه

  8. #8
    قسمت سوم:

    http://www.barnamenevis.org/sh...ad.php?t=38103

    نقل قول نوشته شده توسط babak_delphi
    با سلام خدمت دوستان
    با توجه به اینکه برنامه نویسای زیادی در مورد نحوه تبدیل تاریخ میلادی به شمسی سوال می پرسند من ، این تابع رو به همراه 2 تابع دیگه که یکی برای نمایش عدد بصورت فرمت شده (3 رقم 3رقم از راست) و یکی واسه اینکه 1 edit فقط عدد بگیره ، توی یک unit قرار دادم و کدش رو اینجا گذاشتم.
    نحوه استفاده اونها رو هم با 1 مثال توضیح دادم :





    unit Util;

    interface
    uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, StdCtrls, Tlhelp32;
    type
    function NumberToCurrency(Num: string):string;
    Function IsNum(ch : char) : char;
    Function MiladiToHejri(GregorianDate : String;DateType : Integer) : String;
    implementation

    Function IsNum(ch : char) : char;
    begin
    Try
    if Pos(ch,#8#13'1234567890') = 0 then
    ch := #0;
    Result := ch;
    Except
    Application.MessageBox(' !!! یک اشکال ناشناخته در روند انجام کار پیش آمده است ','ERROR',MB_OK + MB_ICONERROR);
    end;
    end;

    Function MiladiToHejri(GregorianDate : String;DateType : Integer) : String;
    var
    jmm, jdd : string;
    g_days_in_month, j_days_in_month : array[0..11] of Integer;
    HijriMonths : array[1..12] of String;
    g_day_no, j_day_no, jy, jm, gy, gm : Longint;
    j_np, i, jd, GD : Integer;
    flag : Boolean;
    begin
    Try
    flag := true;
    g_days_in_month[0] := 31;
    g_days_in_month[1] := 28;
    g_days_in_month[2] := 31;
    g_days_in_month[3] := 30;
    g_days_in_month[4] := 31;
    g_days_in_month[5] := 30;
    g_days_in_month[6] := 31;
    g_days_in_month[7] := 31;
    g_days_in_month[8] := 30;
    g_days_in_month[9] := 31;
    g_days_in_month[10] := 30;
    g_days_in_month[11] := 31;
    j_days_in_month[0] := 31;
    j_days_in_month[1] := 31;
    j_days_in_month[2] := 31;
    j_days_in_month[3] := 31;
    j_days_in_month[4] := 31;
    j_days_in_month[5] := 31;
    j_days_in_month[6] := 30;
    j_days_in_month[7] := 30;
    j_days_in_month[8] := 30;
    j_days_in_month[9] := 30;
    j_days_in_month[10] := 30;
    j_days_in_month[11] := 29;
    If GregorianDate = Null Then Exit;
    gy := (StrToInt(FormatDateTime('yyyy', StrToDate(GregorianDate)))) - 1600 ;
    gm := (StrToInt(FormatDateTime('mm', StrToDate(GregorianDate)))) - 1 ;
    GD := (StrToInt(FormatDateTime('dd', StrToDate(GregorianDate)))) - 1 ;
    g_day_no := 365 * gy + (gy + 3) div 4 - (gy + 99) div 100 + ( gy + 399) div 400;
    i := 0;
    While i < gm do
    begin
    g_day_no := g_day_no + g_days_in_month[i];
    i := i + 1;
    end;
    If (gm > 1) And (((gy Mod 4 = 0) And (gy Mod 100 <> 0)) Or (gy Mod 400 = 0)) Then
    g_day_no := g_day_no + 1;
    g_day_no := g_day_no + GD;
    j_day_no := g_day_no - 79;
    j_np := j_day_no div 12053;
    j_day_no := j_day_no Mod 12053;
    jy := 979 + 33 * j_np + 4 * (j_day_no div 1461);
    j_day_no := j_day_no Mod 1461;
    If (j_day_no >= 366) Then
    begin
    jy := jy + (j_day_no - 1) div 365;
    j_day_no := (j_day_no - 1) Mod 365;
    End;
    i := 0;
    While (j_day_no >= j_days_in_month[i]) and flag do
    begin
    j_day_no := j_day_no - j_days_in_month[i];
    i := i + 1;
    If i > 12 Then
    begin
    i := 11;
    j_day_no := 29;
    flag := False;
    End;
    end;
    jm := i + 1;
    jd := j_day_no + 1;
    jmm := IntToStr(jm);
    jdd := IntToStr(jd);
    If (Length(jmm) = 1) then
    jmm := '0' + jmm
    else
    jmm := jmm;
    if (Length(jdd) = 1) then
    jdd := '0' + jdd
    else
    jdd := jdd;
    HijriMonths[1] := 'فروردین';
    HijriMonths[2] := 'اردیبهشت';
    HijriMonths[3] := 'خرداد';
    HijriMonths[4] := 'تیر';
    HijriMonths[5] := 'مرداد';
    HijriMonths[6] := 'شهریور';
    HijriMonths[7] := 'مهر';
    HijriMonths[8] := 'آبان';
    HijriMonths[9] := 'آذر';
    HijriMonths[10] := 'دی';
    HijriMonths[11] := 'بهمن';
    HijriMonths[12] := 'اسفند';
    if jmm = '13' then
    begin
    jmm := '12';
    jdd := '30';
    end;
    Case DateType of
    0:
    MiladiToHejri := IntToStr(jy) + '/' + jmm + '/' + jdd;
    1:
    MiladiToHejri := IntToStr(strtoint(jdd)) + ' ' + HijriMonths[StrToInt(jmm)] + ' ' + IntToStr(jy);
    End;
    except
    MiladiToHejri := 'تاریخ وارد شده، اشتباه می باشد .';
    end;
    End;
    function NumberToCurrency(Num: string):string;
    var
    str,buff: string;
    begin
    str := num;
    while Length(str) > 3 do
    begin
    buff := buff + Copy(str,Length(str)-2,3)+'ر';
    Delete(str,Length(str)-2,3);
    end;
    buff := buff+str;
    Result := buff;
    end;
    end.




    برای استفاده کافیست این unit رو هر جا که خواستید uses کنید و توابع رو بصورت زیر استفاده کنید:
    Label1.Caption := NumberToCurrency(Edit1.Text);

    برای اینکه Edit فقط عدد بگیره این کد رو در OnKeyPress ادیت بنویسید :
    Key := IsNum(Key);

    Edit1.Text := MiladiToHejri(DateToStr(Now),0)

    م.فق باشید.
    -------------------------------------------------------------------------------

    http://www.barnamenevis.org/sh...ad.php?t=44663
    نقل قول نوشته شده توسط gbg
    سلام
    کامپوننت تاریخ هجری شمسی رو براتون میزارم
    امکانات این کامپوننت اینه روز هفته رو با نام و عدد نشون میده
    تاریخ رو هم به صورت رشته و هم به صورت عددی داره
    -------------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...685#post233685
    نقل قول نوشته شده توسط (امید)
    فیلد تاریخ در برنامه نویسی به همراه سورس برنامه

    http://www.1padideh.com/index_files/Page2385.htm
    فروردین 85



    امید ولی محمدی admin@1padideh.com



    تاریخ جزو اولین فیلدهای مورد نیاز در برنامه ها ی نرم افزاری می باشد . در تمامی بانک های اطلاعاتی بطور پیش فرض فیلد تاریخ در نظر گرفته شده است . بطور مثال درAccess فیلد تاریخ بصورت Date/Time و در SQLServer این فیلد بصورت datetime تعریف شده است .
    از جمله مشخصات فیلدهای تاریخ این است که صحت ورودی را نیز چک می کنند . بنابراین هنگام ورود تاریخ مقدار روز و ماه و همچنین کاراکتر separator و فرمت بندی چک می شود .

    طبق آنچه گفته شد ورودی های 1.13و2006 - 2006/13/1 و 2006/1/34 نا معتبر و توسط فیلد تاریخ قبول نخواهد شد . فرمت صحیح معمولا بصورت YYYY/MM/DD است و مقدار روز کمتر یا مساوی 32 و مقدار ماه کمتر یا مساوی 12 می باشد .

    خوب حالا ببینیم این فیلد چه میانه ایی با تاریخ شمسی دارد . برای مثال تاریخ 1385/1/13 را در نظر می گیریم که فیلد تاریخ این ورودی را قبول خواهد کرد .تا اینجای بحث همه چیز روبه راه و خوب بنظر می رسد . حال ببینیم مشکل از کجا شروع خواهد شد .

    تاریخ فوق شمسی است . اما برای ما شمسی تعریف شده است . در حالی که این تاریخ برای سیستم میلادی تعریف می شود . البته مشخص است که در اینجا تاریخ تعریف شده برای کاربر مهم است نه سیستم . شاید فکر شود به همین ترتیب می توان با فیلد های تاریخ کار کرد . تاریخ برای سیستم میلادی باشد یا نباشد ما تنها آنرا ذخیره و بازیابی می کنیم و البته در جستجو و گزارش گیری هم مشکلی پیش نخواهد آمد .



    مشکل

    گفتیم فیلد های تاریخ ورودی را از نظر درستی تاریخ چک می کنند . این شاید عالی به نظر برسد اما نه برای تاریخ های شمسی . برای مثال تاریخ 1385/2/31 درست است . ماه اردیبهشت 31 روزه است . اما در تاریخ میلادی ماه دوم 30 روز ندارد و حتی بدتر از آن ماه دوم میلادی 29 روزه است و یادتان باشد که فیلد تاریخ میلادی تعریف شده و صحت ورودی تاریخ را نیز طبیعتا با فرمت میلادی می سنجد . پس اگر به این ترتیب بخواهیم با تاریخ کار کنیم با تاریخ های 1385/2/31 و 1385/2/30 و چند تاریخ دیگر مشکل خواهیم داشت . و چون نمی شود از کاربران خواست با چند تاریخ بخصوص کار نکنند , باید به فکر راه دیگری باشیم .



    راه های دیگر :

    راه اول :

    تاریخ بصورت شمسی وارد می شود . قبل از ثبت در بانک اطلاعاتی , ورودی ما به تاریخ میلادی برگردانده می شود و بعد از تبدیل مقدار که اینک تاریخ میلادی در بانک ثبت می شود .

    برای مثال :

    تاریخ ورودی : 1385/01/13

    تبدیل به میلادی : 2006/04/02

    و حالا ثبت تاریخ میلادی در بانک

    مشخص است که برای نمایش باید روند فوق برعکس انجام شود .

    اشکالات این راه حل : توابع تبدیل تاریخ خود یکی از مشکلات این راه حل است . البته نگران این مورد نباشید چون در انتها لینک دانلود سورس برنامه ( توابع ) آورده شده است . البته سورس ها به زبان دلفی می باشد .

    اشکال بعدی : در اینجا دوبار , تبدیل تاریخ داریم . و از همه مهمتر هنگام جستجوی یک محدوده زمانی در رکوردهای بیشمار زمانی زیادی صرف می شود.

    بعید می دانم برنامه نویسی بطور کاربردی از این روش استفاده کند.


    راه دوم : راه دیگر استفاده از فیلد text می باشد . شاید ساده ترین روش بنظر برسد . البته در مرتب سازی ها و گزارش گیری های متنوع شاید اندکی برنامه نویس , بخصوص مبتدیان را دچار مشکل کند .


    راه سوم : راه سوم که روش پیشنهادی می باشد استفاده از دو فیلد text و number برای ثبت تاریخ می باشد .

    فیلد text برای دخیره تاریخ ورودی و نمایش آن .

    و فیلد number برای مرتب سازی و گزارشات و جستجو ها .


    مثال :

    فیلد myText از نوع text و فیلد DateNo از نوع Number تعریف می کنیم .

    همانطور که ملاحظه می کنید با حذف separator ( / ) عددی خواهیم داشت که معرف تاریخ مورد نظر می باشد . بر اساس این عدد جدول را می توانیم مرتب کنیم و به سادگی می توانیم گزارشات متنوعی داشته باشیم.

    تاریخ ورودی 1384/01/13

    عینا ذخیره در فیلد myDate

    و عدد 13840113 که معرف تاریخ فوق است و ذخیره در فیلد DateNo جهت جستجو و زارش گیری و مرتب سازی .

    جدول زیر برای نمونه این روش را بطور گویا تری نشان می دهد

    سورس برنامه تبدیل تاریخ شمسی به میلادی و برعکس ( از آقای بابک یعقوبی )

    از هر روشی که با فیلدهای تاریخ کار کنیم , استفاده از تبدیل تاریخ میلادی به شمسی و برعکس اجتناب ناپذیر است .

    برنامه های زیادی در این مورد نوشته شده است . برنامه پیشنهادی , برنامه ایی می باشد که آقای بابک یعقوبی نوشته اند .شخصا تا بحال با این برنامه مشکلی نداشته ام و جا دارد بار دیگر از آقای بابک یعقوبی تشکر کنم .

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

    Type of file : WinRAR archive

    Open with : WinRAR

    Size : 13.7 KB (14,057 bytes)
    - استفاده از مقاله با ذکر منبع و نویسنده اشکالی ندارد -
    http://www.1padideh.com/index_files/Page2385.htm
    ---------------------------------------------------------------------------
    http://www.barnamenevis.org/sh...%D3#post239707
    کامپوننت تقویم فارسی
    نقل قول نوشته شده توسط B_YAGHOBI
    رایگان - فول سورس
    -----------------------------------------------------------------------
    https://barnamenevis.org/showthread.php?t=53693
    نقل قول نوشته شده توسط mehdi_mohamadi
    تبدیل تاریخ میلادی به شمسی

  9. #9
    کاربر دائمی آواتار Touska
    تاریخ عضویت
    مرداد 1383
    محل زندگی
    ایران زمین
    سن
    37
    پست
    1,987
    فکر خیلی خوبی بود :)

  10. #10
    کاربر دائمی آواتار MiRHaDi
    تاریخ عضویت
    تیر 1383
    محل زندگی
    تهران - سوهانک
    پست
    982
    سلام
    تشکر از زحمت شما.
    اگه دوستان موضوعات مختلف رو به همین صورت دسته بندی و جمع بندی کنند خیلی عالی میشه
    بازم تشکر
    بای

  11. #11
    خواهش می کنم. :لبخندساده

  12. #12
    کار خیلی خوبی بود!
    ولی لینک مربوط به کامپوننت TFarsiDate قدیمیه!

    لینک دانلود: http://www.salarsoft.somee.com/downl....htm#farsidate
    لینک مستقیم دانلود: http://salarsoft.somee.com/downloads/free/farsidate.zip
    لینک توضیحات: http://www.salarsoft.somee.com/magal..._date_help.htm
    آخرین ویرایش به وسیله SalarSoft : پنج شنبه 20 بهمن 1384 در 10:10 صبح

  13. #13
    نقل قول نوشته شده توسط SalarSoft
    ولی لینک مربوط به کامپوننت TFarsiDate قدیمیه!
    ممنونم.
    تصحیح شد.

  14. #14
    کاربر دائمی آواتار babak_delphi
    تاریخ عضویت
    اردیبهشت 1384
    محل زندگی
    آستارا
    پست
    634
    من یکی از این توابع رو اصلاح کردم و 1 تابع جدید هم اضافه کردم

    اینم لینکش
    http://www.barnamenevis.org/sh...ad.php?t=38103

  15. #15
    نقل قول نوشته شده توسط babak_delphi
    من یکی از این توابع رو اصلاح کردم و 1 تابع جدید هم اضافه کردم

    اینم لینکش
    http://www.barnamenevis.org/sh...ad.php?t=38103
    متشکر
    تصحیح شد

  16. #16
    کاربر جدید
    تاریخ عضویت
    بهمن 1381
    محل زندگی
    Iran
    پست
    9

    نیاز تبدیل تاریخ میلادی به شمسی و بلعکس در اکسل

    یکی مشکل منو حل کنه ؟

    http://www.barnamenevis.org/sh...ighlight=excel

  17. #17
    کاربر جدید آواتار mrkh1759
    تاریخ عضویت
    اسفند 1384
    محل زندگی
    IRAN-TEHRAN
    پست
    8

    Thumbs up تشکر

    ممنونم دوست محترم .

  18. #18
    کارت جالب بود .

    موفق باشید .

  19. #19

  20. #20
    salam
    kheili bahalin

  21. #21
    برای استفاده بهینه از مطالب بهترین کاره

قوانین ایجاد تاپیک در تالار

  • شما نمی توانید تاپیک جدید ایجاد کنید
  • شما نمی توانید به تاپیک ها پاسخ دهید
  • شما نمی توانید ضمیمه ارسال کنید
  • شما نمی توانید پاسخ هایتان را ویرایش کنید
  •