PDA

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



(امید)
دوشنبه 12 اسفند 1381, 06:39 قبل از ظهر
از آقای بابک یعقوبی ( برداشت شده از 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.

بابک یعقوبی

MiRHaDi
دوشنبه 23 شهریور 1383, 10:10 قبل از ظهر
سلام
این کدی که بالا نوشته شده مشکل داره ! البته یک مشکل کوچیک ! این زمان رو به این صورت تفسیم میکنه که هر دوره 128 ساله رو به 4 32 سال در میاره و ... !
ولی در تاریخ شمسی مصوبه 1320 دوره زمانی تاریخ شمسی 4820 سال تعریف شده و سیستمش یک مقدار فرق داره
من کد اون رو نوشتم . احتمالا باید یک سایت فارسی کامپاننت درست کنم !
آقا خرجش در میاد ؟
بای

SalarSoft
پنجشنبه 02 مهر 1383, 07:08 قبل از ظهر
با عرض پوزش بسیار از جناب (امید)
این کد مقدار های سال، ماه و روز را به طور جدا گانه در رکورد t_date ذخیره میکند. اگرچه کار تبدیل به طور درست و کامل انجام می شه ولی با توجه به این که اطلاعات در رکورد استاندارد تاریخ در دلفی (TDateTime) ذخیره نمیشه؛ ممکنه که ما رو با محدودیت هایی مواجه کنه! :متفکر:

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

در حقیقت علت مشکل توابعی که از TDateTime برای تاریخ شمسی استفاده می کنند وجود ثابت MonthDays است که برای ماه های میلادی می باشد.
در این کلاس با تعریف ثابت FarMonthDays برای ماه های شمسی این مشکل حل شده است.
موفق باشید.