中国农历算法(delphi)

// 节日算法 请参见 《农历与西历对照、万年历》
unit CNYear;

interface

uses sysutils;

type TCNDate = Cardinal;

function DecodeGregToCNDate(dtGreg:TDateTime):TCNDate;
function GetGregDateFromCN(cnYear,cnMonth,cnDay:word;bLeap:Boolean=False):TDateTime;
function GregDateToCNStr(dtGreg:TDateTime):String;
function isCNLeap(cnDate:TCNDate):boolean;

implementation

const cstDateOrg:Integer=32900; //公历1990-01-27的TDateTime表示 对应农历1990-01-01
const cstCNYearOrg=1990;
const cstCNTable:array[cstCNYearOrg..cstCNYearOrg + 60] of WORD=(       //   unsigned 16-bit
24402, 3730, 3366, 13614, 2647, 35542, 858, 1749,           //1997
23401, 1865, 1683, 19099, 1323, 2651, 10926, 1386,           //2005
32213, 2980, 2889, 23891, 2709, 1325, 17757, 2741,           //2013
39850, 1490, 3493, 61098, 3402, 3221, 19102, 1366,           //2021
2773, 10970, 1746, 26469, 1829, 1611, 22103, 3243,           //2029
1370, 13678, 2902, 48978, 2898, 2853, 60715, 2635,           //2037
1195, 21179, 1453, 2922, 11690, 3474, 32421, 3365,           //2045
2645, 55901, 1206, 1461, 14038);                             //2050
//建表方法：
// 0101 111101010010     高四位是闰月位置,后12位表示大小月,大月30天,小月29天,
//闰月一般算小月,但是有三个特例2017/06,2036/06,2047/05
//对于特例则高四位的闰月位置表示法中的最高为设置为1 特殊处理用wLeapNormal变量
// //2017/06 28330->61098 2036/06 27947->60715 2047/05 23133->55901

//如果希望用汇编,这里有一条信息:农历不会滞后公历2个月.
//将公历转换为农历
//返回:12位年份+4位月份+5位日期
function DecodeGregToCNDate(dtGreg:TDateTime):TCNDate;
var
  iDayLeave:Integer;
  wYear,wMonth,wDay:WORD;
  i,j:integer;
  wBigSmallDist,wLeap,wCount,wLeapShift:WORD;
label OK;
begin
  result := 0;
  iDayLeave := Trunc(dtGreg) - cstDateOrg;
  DecodeDate(IncMonth(dtGreg,-1),wYear,wMonth,wDay);
  if (iDayLeave < 0) or (iDayLeave > 22295 )then Exit;
              //Raise Exception.Create('目前只能算1990-01-27以后的');
              //Raise Exception.Create('目前只能算2051-02-11以前的');
  for i:=Low(cstCNTable)   to High(cstCNTable) do begin
      wBigSmallDist := cstCNTable[i];
      wLeap := wBigSmallDist shr 12;
      if wLeap > 12 then begin
          wLeap := wLeap and 7;
          wLeapShift := 1;
      end else
          wLeapShift := 0;
      for j:=1 to 12 do begin
          wCount:=(wBigSmallDist and 1) + 29;
          if j=wLeap then wCount := wCount - wLeapShift;
          if iDayLeave < wCount   then begin
              Result := (i shl 9) + (j shl 5) + iDayLeave + 1;
              Exit;
          end;
          iDayLeave := iDayLeave - wCount;
          if j=wLeap then begin
              wCount:=29 + wLeapShift;
              if iDayLeave < wCount   then begin
                  Result := (i shl 9) + (j shl 5) + iDayLeave + 1 + (1 shl 21);
                  Exit;
              end;
              iDayLeave := iDayLeave - wCount;
          end;
          wBigSmallDist := wBigSmallDist shr 1;
      end;
  end;
//返回值:
// 1位闰月标志 + 12位年份+4位月份+5位日期             (共22位)
end;

function isCNLeap(cnDate:TCNDate):boolean;
begin
  result := (cnDate and $200000) <> 0;
end;

function GetGregDateFromCN(cnYear,cnMonth,cnDay:word;bLeap:Boolean=False):TDateTime;
var
  i,j:integer;
  DayCount:integer;
  wBigSmallDist,wLeap,wLeapShift:WORD;
begin
  // 0101 010010101111     高四位是闰月位置,后12位表示大小月,大月30天,小月29天,
  DayCount := 0;
  if (cnYear < 1990) or (cnYear >2050) then begin
      Result := 0;
      Exit;
  end;
  for i:= cstCNYearOrg to cnYear-1 do begin
        wBigSmallDist := cstCNTable[i];
        if (wBIgSmallDist and $F000) <> 0 then DayCount := DayCount + 29;
        DayCount := DayCount + 12 * 29;
        for j:= 1 to 12 do begin
            DayCount := DayCount + wBigSmallDist and 1;
            wBigSmallDist := wBigSmallDist shr 1;
        end;
  end;
  wBigSmallDist := cstCNTable[cnYear];
  wLeap := wBigSmallDist shr 12;
  if wLeap > 12 then begin
      wLeap := wLeap and 7;
      wLeapShift := 1;                       //大月在闰月.
  end else
      wLeapShift := 0;
  for j:= 1 to cnMonth-1 do begin
      DayCount:=DayCount + (wBigSmallDist and 1) + 29;
      if j=wLeap then DayCount := DayCount + 29;
      wBigSmallDist := wBigSmallDist shr 1;
  end;
  if bLeap and (cnMonth = wLeap)   then   //是要闰月的吗?
      DayCount := DayCount + 30 - wLeapShift;
  result := cstDateOrg + DayCount + cnDay - 1;
end;

//将日期显示成农历字符串.
function GregDateToCNStr(dtGreg:TDateTime):String;
const hzNumber:array[0..10] of string=('零','一','二','三','四','五','六','七','八','九','十');
function ConvertYMD(Number:Word;YMD:Word):string;
var
  wTmp:word;
begin
  result := '';
  if YMD = 1 then begin //年份
      while Number > 0 do begin
          result := hzNumber[Number Mod 10] + result;
          Number := Number DIV 10;
      end;
      Exit;
  end;
  if Number<=10 then begin   //可只用1位
      if YMD = 2 then //月份
          result := hzNumber[Number]
      else                       //天
          result := '初' + hzNumber[Number];
      Exit;
  end;
  wTmp := Number Mod 10;   //个位
  if wTmp <> 0 then result := hzNumber[wTmp];
  wTmp := Number Div 10;           //十位
  result:='十'+result;
  if wTmp > 1 then   result := hzNumber[wTmp] + result;
end;
var
  cnYear,cnMonth,cnDay:word;
  cnDate:TCNDate;
  strLeap:string;
begin
  cnDate:= DecodeGregToCNDate(dtGreg);
  if cnDate = 0 then begin
      result := '输入越界';
      Exit;                
  end;
  cnDay := cnDate and $1F;
  cnMonth := (cnDate shr 5) and $F;
  cnYear := (cnDate shr 9) and $FFF;
  //测试第22位,为1表示闰月
  if isCNLeap(cnDate) then strLeap:='(闰)' else   strLeap := '';
  result := '农历' + ConvertYMD(cnYear,1) + '年' + ConvertYMD(cnMonth,2) + '月'
                + strLeap + ConvertYMD(cnDay,3) ;
end;

end.

//////////////////////////  应用 /////////////////////////////
uses CNYear;

procedure TForm1.Button1Click(Sender: TObject);
begin
  edit1.text:=GregDateToCNStr(DateTimePicker1.date);
end;