از آقای بابک یعقوبی ( برداشت شده از 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.
بابک یعقوبی
