calendar.pas

木马源程序,供大家研究

  if Result=0 then Result:=51

  else Result:=Result-1;

end;

function WeekNum(const iYear,iMonth,iDay:Word):Word;

begin

  Result:=WeekNum(EncodeDate(iYear,iMonth,iDay));

end;

function MonthDays(iYear,iMonth:Word):Word;

begin

  case iMonth of

    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;

function GetLunarDate(iYear,iMonth,iDay:Word;var

  iLunarYear,iLunarMonth,iLunarDay:Word):Word;

begin

  l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(iYear,iMonth,

    iDay));

  Result:=l_GetLunarHolDay(iYear,iMonth,iDay);

end;

procedure GetLunarDate(InDate:TDateTime;var

  iLunarYear,iLunarMonth,iLunarDay:Word);

begin

  l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(InDate,

    EncodeDate(START_YEAR,1,1)));

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:=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 Result:='';

  end;

end;

function GetLunarHolDay(iYear,iMonth,iDay:Word):string;

begin

  Result:=GetLunarHolDay(EncodeDate(iYear,iMonth,iDay));

end;

function FormatWeek(Date : TDatetime; Format : Integer): string;

const

  weeks : array[1..4, 1..7] of string = (

    ('星期天', '星期一', '星期二', '星期三', '星期四', '星期五', '星期六'),

    ('礼拜天', '礼拜一', '礼拜二', '礼拜三', '礼拜四', '礼拜五', '礼拜六'),

    ('周日', '周一', '周二', '周三', '周四', '周五', '周六'),

    ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday')

  );

begin

  result := weeks[Format][DayOfWeek(Date)];

end;

function FormatTime(Time : TDatetime; Format : Integer): string;

const

  Hours : widestring = '子丑寅卯辰巳午未申酉戌亥';

  Mins : widestring = '一二三四五六七八';

var

  H, M, S, V : Word;

begin

  case Format of

    1 : begin

      DecodeTime(Time, H, M, S, V);

      M := M + abs( (H mod 2) -1 ) * 60;

      M := (M div 15) + 1;

      H := (H div 2) + (H mod 2);

      If H = 0 then H := 1;

      result := Hours[H] + '时' + Mins[M] + '刻' ;

    end;

    2 : result := formatDatetime('h"时"mm"分"ss"秒"', Time);

    3 : result := formatDatetime('ampmh"时"mm"分', Time);

    4 : result := formatDatetime('hh":"mm":"ss', Time);

    5 : result := formatDatetime('hh":"mm', Time);

  end;

end;

function FormatDate(Date : TDatetime; Format : Integer = 4): string;

const

  DateNums : array[1..2] of widestring = (

    '○一二三四五六七八九', '零壹贰叁肆伍陆柒捌玖' );

var

  DateStr : widestring;

  I : integer;

  LY, LM, LD:Word;

begin

  case Format of

    1 : begin

      GetLunarDate(Date, LY, LM, LD);

      result := FormatLunarYear(LY) + FormatMonth(LM) + FormatLunarDay(LD);

    end;

    2 : result := FormatDatetime('yyyy"-"mm"-"d', date);

    3 : result := FormatDatetime('yyyy"/"mm"/"d', date);

    4..6 : result := FormatDatetime('yyyy"年"mm"月"d"日"', date);

  end;

  If format in [5..6] then

  begin

    DateStr := result;

    for I := 1 to Length(DateStr) do

      If ord(DateStr[I]) in [48..57] then

        DateStr[I] := dateNums[format-4][ord(DateStr[I])-47];

    result := DateStr;

  end;

end;

end.