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

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

  1. #1

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

    از آقای بابک یعقوبی ( برداشت شده از 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 < 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 < 100 then sh.y := sh.y + 1300;
    if sh.y < _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 < 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 < SHKMONTH))
    then
    el := el + 366
    else
    el := el + 365;
    dec(sh.y);
    end;
    yt := sh.y;
    mt := sh.m - 1;
    if mt < 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 < 1 do begin
    sh.m := sh.m + 12;
    dec(sh.y);
    end;
    yt := sh.y;
    mt := sh.m - 1;
    if mt < 1 then begin
    mt := 12;
    dec(yt);
    end;
    end;
    sh.d := sh.d + el;
    while (sh.d <= 0) do
    begin
    yt := sh.y;
    mt := sh.m - 1;
    if mt < 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 < 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 <= 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.


    بابک یعقوبی

  2. #2
    کاربر دائمی آواتار MiRHaDi
    تاریخ عضویت
    تیر 1383
    محل زندگی
    تهران - سوهانک
    پست
    982
    سلام
    این کدی که بالا نوشته شده مشکل داره ! البته یک مشکل کوچیک ! این زمان رو به این صورت تفسیم میکنه که هر دوره 128 ساله رو به 4 32 سال در میاره و ... !
    ولی در تاریخ شمسی مصوبه 1320 دوره زمانی تاریخ شمسی 4820 سال تعریف شده و سیستمش یک مقدار فرق داره
    من کد اون رو نوشتم . احتمالا باید یک سایت فارسی کامپاننت درست کنم !
    آقا خرجش در میاد ؟
    بای

  3. #3
    با عرض پوزش بسیار از جناب (امید)
    این کد مقدار های سال، ماه و روز را به طور جدا گانه در رکورد t_date ذخیره میکند. اگرچه کار تبدیل به طور درست و کامل انجام می شه ولی با توجه به این که اطلاعات در رکورد استاندارد تاریخ در دلفی (TDateTime) ذخیره نمیشه؛ ممکنه که ما رو با محدودیت هایی مواجه کنه!

    از این رو مدتی قبل مجموعه توابعی رو نوشتم که این کار رو بر روی TDateTime انجام می دهد.
    آدرسش:http://www.salarsoft.somee.com/downl....htm#farsidate
    در ضمن حتما به نحوه استفاده دقت کنید.مثلا: TFarDate.MiladyToShamsi(Now) که نیازی به Create کردن کلاس TFarDate نمی باشد.

    در حقیقت علت مشکل توابعی که از TDateTime برای تاریخ شمسی استفاده می کنند وجود ثابت MonthDays است که برای ماه های میلادی می باشد.
    در این کلاس با تعریف ثابت FarMonthDays برای ماه های شمسی این مشکل حل شده است.
    موفق باشید.
    آخرین ویرایش به وسیله SalarSoft : پنج شنبه 05 آبان 1384 در 14:40 عصر

تاپیک های مشابه

  1. تبدیل تاریخ از میلادی به شمسی در اسکریپت
    نوشته شده توسط maya2010 در بخش PHP
    پاسخ: 12
    آخرین پست: سه شنبه 21 شهریور 1391, 13:09 عصر
  2. تبدیل تاریخ از میلادی به شمسی در اسکریپت
    نوشته شده توسط maya2010 در بخش PHP
    پاسخ: 0
    آخرین پست: یک شنبه 15 فروردین 1389, 01:20 صبح
  3. نحوه تبدیل تاریخ از میلادی به شمسی در NTTacPlus
    نوشته شده توسط amir00002 در بخش شبکه و Networking‌
    پاسخ: 0
    آخرین پست: دوشنبه 04 اردیبهشت 1385, 20:43 عصر
  4. تبدیل تاریخ از میلادی به شمسی و بر عکس
    نوشته شده توسط programersa در بخش برنامه نویسی در Delphi
    پاسخ: 5
    آخرین پست: جمعه 30 دی 1384, 11:28 صبح
  5. تبدیل تاریخ از میلادی به شمسی
    نوشته شده توسط omid1974 در بخش ASP.NET Web Forms
    پاسخ: 15
    آخرین پست: دوشنبه 29 فروردین 1384, 03:15 صبح

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

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