کد:
procedure TForm1.FormCreate(Sender: TObject);
var
m2, d2, Today, Day, DateComplete: string;
total: longint;
m1, y1, y2, d1, y, m, temp, d: word;
a, b, a1: array [1..12] of word;
begin
Today:='';
a[1]:=31; a[2]:=28; a[3]:=31; a[4]:=30; a[5]:=31; a[6]:=30;a[7]:=31;a[8]:=31;a[9]:=30;a[10]:=31;a[11]:=30;a[12]:=31;
b[1]:=31;b[2]:=29;b[3]:=31;b[4]:=30;b[5]:=31;b[6]:=30;b[7]:=31;b[8]:=31;b[9]:=30;b[10]:=31;b[11]:=30;b[12]:=31;
a1[1]:=31;a1[2]:=31;a1[3]:=31;a1[4]:=31;a1[5]:=31;a1[6]:=31;a1[7]:=30;a1[8]:=30;a1[9]:=30;a1[10]:=30;a1[11]:=30;a1[12]:=29; total:=0;
y := strtoint(formatdatetime('yy', now()));
temp := y;
m := strtoint(formatdatetime('m', now()));
d := strtoint(formatdatetime('d', now()));
if y mod 4 = 0 then
dec(total);
while y > 3 do
begin
if y mod 4=0 then
inc(total,366)
else
inc(total, 365);
dec(y);
end;
while m > 1 do
begin
if temp mod 4 = 0 then
inc(total, b[m-1])
else
inc(total, a[m-1]);
dec(m);
end;
inc(total, d);
inc(total, 9);
y1 := 1381;m1 := 10;d1 := 1;
while total > 364 do
if y1 mod 4 = 3 then
if total > 365 then
begin
dec(total, 366);
inc(y1);
end
else break
else
begin
dec(total, 365);
inc(y1);
end;
while total > 28 do
begin
if m1 = 12 then
begin
if y1 mod 4 = 3 then
if total>29 then
begin
dec(total,30);
end
else break
else
dec(total, 29);
inc(y1);
m1 := 1;
end;
if total >= a1[m1] then
begin
dec(total, a1[m1]);
inc(m1);
end
else
break;
end;
inc(d1, total);
if (m1)<10 then
M2 := '0'+IntToStr(m1)
else
M2 := IntToStr(m1);
if (d1)<10 then
d2 := '0'+IntToStr(d1)
else
d2 :=IntToStr(d1);
y2 := y1 - 1300;
Today := FormatDateTime('dddd',Now());
DateComplete := Today + ' : ' + d2 + ' / ' + m2 + ' / ' + inttostr(y1);
Day := IntToStr(y2) + '/' + m2 + '/' + d2;
Lable1.Caption := DateComplete;
end;