nldate.pas

一款不错的年历控件

   1,3,5,7,8,10,12: Result:=31;
   4,6,9,11: Result:=30;
   2://如果是闰年
     if IsLeapYear(iYear) then
       Result:=29
     else
       Result:=28
 else
   Result:=0;
 end;
end;

function GetLeapMonth(iLunarYear:Word):Word; 
var
 Flag:Byte;
begin
 Flag:=gLunarMonth[(iLunarYear-START_YEAR) div 2];
 if (iLunarYear-START_YEAR) mod 2=0 then
   Result:=Flag shr 4
 else
   Result:=Flag and $0F;
end;

function LunarMonthDays(iLunarYear,iLunarMonth:Word):Longword;
var
 Height,Low:Word;
 iBit:Integer;
begin
 if iLunarYear<START_YEAR then
 begin
   Result:=30;
   Exit;
 end;
 Height:=0;
 Low:=29;
 iBit:=16-iLunarMonth;
 if (iLunarMonth>GetLeapMonth(iLunarYear)) and (GetLeapMonth(iLunarYear)>0) then
   Dec(iBit);
 if (gLunarMonthDay[iLunarYear-START_YEAR] and (1 shl iBit))>0 then
   Inc(Low);
 if iLunarMonth=GetLeapMonth(iLunarYear) then
   if (gLunarMonthDay[iLunarYear-START_YEAR] and (1 shl (iBit-1)))>0 then
     Height:=30
   else
     Height:=29;
 Result:=MakeLong(Low,Height);
end;

function LunarYearDays(iLunarYear:Word):Word;
var
 Days,i:Word;
 tmp:Longword;
begin
 Days:=0;
 for i:=1 to 12 do
 begin
   tmp:=LunarMonthDays(iLunarYear,i);
   Days:=Days+HiWord(tmp);
   Days:=Days+LoWord(tmp);
 end;
 Result:=Days;
end;

procedure FormatLunarYear(iYear:Word;var pBuffer:string);
var
 szText1,szText2,szText3:string;
begin
 szText1:='甲乙丙丁戊己庚辛壬癸';
 szText2:='子丑寅卯辰巳午未申酉戌亥';
 szText3:='鼠牛虎免龙蛇马羊猴鸡狗猪';
 pBuffer:=Copy(szText1,((iYear-4) mod 10)*2+1,2);
 pBuffer:=pBuffer+Copy(szText2,((iYear-4) mod 12)*2+1,2);
 pBuffer:=pBuffer+' ';
 pBuffer:=pBuffer+Copy(szText3,((iYear-4) mod 12)*2+1,2);
 pBuffer:=pBuffer+'年';
end;

function FormatLunarYear(iYear:Word):string;
var
 pBuffer:string;
begin
 FormatLunarYear(iYear,pBuffer);
 Result:=pBuffer;
end;

procedure FormatMonth(iMonth:Word;var pBuffer:string;bLunar:Boolean);
var
 szText:string;
begin
 if (not bLunar) and (iMonth=1) then
 begin
   pBuffer:='  一月';
   Exit;
 end;
 szText:='正二三四五六七八九十';
 if iMonth<=10 then
 begin
   pBuffer:='  ';
   pBuffer:=pBuffer+Copy(szText,(iMonth-1)*2+1,2);
   pBuffer:=pBuffer+'月';
   Exit;
 end;
 if iMonth=11 then
   pBuffer:='十一'
 else
   pBuffer:='十二';
 pBuffer:=pBuffer+'月';
end;

function FormatMonth(iMonth:Word;bLunar:Boolean):string;
var
 pBuffer:string;
begin
 FormatMonth(iMonth,pBuffer,bLunar);
 Result:=pBuffer;
end;

procedure FormatLunarDay(iDay:Word;var pBuffer:string);
var
 szText1,szText2:string;
begin
 szText1:='初十廿三';
 szText2:='一二三四五六七八九十';
 if (iDay<>20) and (iDay<>30) then
 begin
   pBuffer:=Copy(szText1,((iDay-1) div 10)*2+1,2);
   pBuffer:=pBuffer+Copy(szText2,((iDay-1) mod 10)*2+1,2);
 end
 else
 begin
   pBuffer:=Copy(szText1,(iDay div 10)*2+1,2);
   pBuffer:=pBuffer+'十';
 end;
end;

function FormatLunarDay(iDay:Word):string;
var
 pBuffer:string;
begin
 FormatLunarDay(iDay,pBuffer);
 Result:=pBuffer;
end;

function CalcDateDiff(iEndYear,iEndMonth,iEndDay:Word;iStartYear:Word;iStartMonth:Word;iStartDay:Word):Longword;
begin
 Result:=Trunc(EncodeDate(iEndYear,iEndMonth,iEndDay)-EncodeDate(iStartYear,iStartMonth,iStartDay));
end;

function CalcDateDiff(EndDate,StartDate:TDateTime):Longword;
begin
 Result:=Trunc(EndDate-StartDate);
end;

procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);
var
 tmp:Longword;
begin
 //阳历1901年2月19日为阴历1901年正月初一
 //阳历1901年1月1日到2月19日共有49天
 if iSpanDays<49 then
 begin
   iYear:=START_YEAR-1;
   if iSpanDays<19 then
   begin
     iMonth:=11;
     iDay:=11+Word(iSpanDays);
   end
   else
   begin
     iMonth:=12;
     iDay:=Word(iSpanDays)-18;
   end;
   Exit;
 end;
 //下面从阴历1901年正月初一算起
 iSpanDays:=iSpanDays-49;
 iYear:=START_YEAR;
 iMonth:=1;
 iDay:=1;
 //计算年
 tmp:=LunarYearDays(iYear);
 while iSpanDays>=tmp do
 begin
   iSpanDays:=iSpanDays-tmp;
   Inc(iYear);
   tmp:=tmp + LunarYearDays(iYear);
 end;
 //计算月
 tmp:=LoWord(LunarMonthDays(iYear,iMonth));
 while iSpanDays>=tmp do
 begin
   iSpanDays:=iSpanDays-tmp;
   if iMonth=GetLeapMonth(iYear) then 
begin
     tmp:=HiWord(LunarMonthDays(iYear,iMonth));
     if iSpanDays<tmp then Break;
     iSpanDays:=iSpanDays-tmp;
   end;
   Inc(iMonth);
   tmp:=LoWord(LunarMonthDays(iYear,iMonth));
 end;
 //计算日
 iDay:=iDay+Word(iSpanDays);
end;

function l_GetLunarHolDay(iYear,iMonth,iDay:Word):Word;
var
 Flag:Byte;
 Day:Word;
begin
 Flag:=gLunarHolDay[(iYear-START_YEAR)*12+iMonth-1];
 if iDay<15 then
   Day:=15-((Flag shr 4) and $0f)
 else
   Day:=(Flag and $0f)+15;
 if iDay=Day then
   if iDay>15 then
     Result:=(iMonth-1)*2+2
   else
     Result:=(iMonth-1)*2+1
 else
   Result:= 0;
end;

function GetLunarHolDay(InDate:TDateTime):string;
var
 i,iYear,iMonth,iDay:Word;
begin
 DecodeDate(InDate,iYear,iMonth,iDay);
 i:=l_GetLunarHolDay(iYear,iMonth,iDay);
 case i of
   1:Result:='小 寒';
   2:Result:='大 寒';
   3:Result:='立 春';
   4:Result:='雨 水';
   5:Result:='惊 蛰';
   6:Result:='春 分';
   7:Result:='清 明';
   8:Result:='谷 雨';
   9:Result:='立 夏';
   10:Result:='小 满';
   11:Result:='芒 种';
   12:Result:='夏 至';
   13:Result:='小 暑';
   14:Result:='大 暑';
   15:Result:='立 秋';
   16:Result:='处 暑';
   17:Result:='白 露';
   18:Result:='秋 分';
   19:Result:='寒 露';
   20:Result:='霜 降';
   21:Result:='立 冬';
   22:Result:='小 雪';
   23:Result:='大 雪';
   24:Result:='冬 至';
 else
   l_CalcLunarDate(iYear,iMonth,iDay,CalcDateDiff(InDate,EncodeDate(START_YEAR,1,1)));
   Result := trim(FormatMonth(iMonth) + FormatLunarDay(iDay));
 end;
end;

function GetLunarHolDay(iYear,iMonth,iDay:Word):string;
begin
 Result:=GetLunarHolDay(EncodeDate(iYear,iMonth,iDay));
end;
end.