精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>Object Pascal语言>>Re:请高手提供一个公历转农历的公式或算法,thx(内空)

主题:Re:请高手提供一个公历转农历的公式或算法,thx(内空)
发信人: delphilxh(先锋)
整理人: teleme(2001-11-03 18:00:18), 站内信件
unit DateCn; 

interface 

uses Windows, SysUtils, Controls; 

const 
  //农历月份数据,每年4字节,从1901年开始,共150年 
  //数据来源:UCDOS 6.0 UCT.COM 
  //分析整理:Copyright (c) 1996-1998, Randolph 
  //数据解析: 
  //如果第一字节的bit7为1,则该年1月1日位于农历12月,否则位于11月 
  //第一字节去除bit7为该年1月1日的农历日期 
  //        第二字节                第三字节 
  //bit:    7  6  5  4  3  2  1  0  7  6  5  4  3  2  1  0 
  //农历月份:16 15 14 13 12 11 10 9  8  7  6  5  4  3  2  1 
  //农历月份指的是从该年1月1日的农历月份算起的顺序号 
  //农历月份对应的bit为1则该月为30日,否则为29日 
  //第四字节为闰月月份 
  CnData: array[0..599] of Byte = ( 
    $0b,$52,$ba,$00,$16,$a9,$5d,$00,$83,$a9,$37,$05,$0e,$74,$9b,$00, 
    $1a,$b6,$55,$00,$87,$b5,$55,$04,$11,$55,$aa,$00,$1c,$a6,$b5,$00, 
    $8a,$a5,$75,$02,$14,$52,$ba,$00,$81,$52,$6e,$06,$0d,$e9,$37,$00, 
    $18,$74,$97,$00,$86,$ea,$96,$05,$10,$6d,$55,$00,$1a,$35,$aa,$00, 
    $88,$4b,$6a,$02,$13,$a5,$6d,$00,$1e,$d2,$6e,$07,$0b,$d2,$5e,$00, 
    $17,$e9,$2e,$00,$84,$d9,$2d,$05,$0f,$da,$95,$00,$19,$5b,$52,$00, 
    $87,$56,$d4,$04,$11,$4a,$da,$00,$1c,$a5,$5d,$00,$89,$a4,$bd,$02, 
    $15,$d2,$5d,$00,$82,$b2,$5b,$06,$0d,$b5,$2b,$00,$18,$ba,$95,$00, 
    $86,$b6,$a5,$05,$10,$56,$b4,$00,$1a,$4a,$da,$00,$87,$49,$ba,$03, 
    $13,$a4,$bb,$00,$1e,$b2,$5b,$07,$0b,$72,$57,$00,$16,$75,$2b,$00, 
    $84,$6d,$2a,$06,$0f,$ad,$55,$00,$19,$55,$aa,$00,$86,$55,$6c,$04, 
    $12,$c9,$76,$00,$1c,$64,$b7,$00,$8a,$e4,$ae,$02,$15,$ea,$56,$00, 
    $83,$da,$55,$07,$0d,$5b,$2a,$00,$18,$ad,$55,$00,$85,$aa,$d5,$05, 
    $10,$53,$6a,$00,$1b,$a9,$6d,$00,$88,$a9,$5d,$03,$13,$d4,$ae,$00, 
    $81,$d4,$ab,$08,$0c,$ba,$55,$00,$16,$5a,$aa,$00,$83,$56,$aa,$06, 
    $0f,$aa,$d5,$00,$19,$52,$da,$00,$86,$52,$ba,$04,$11,$a9,$5d,$00, 
    $1d,$d4,$9b,$00,$8a,$74,$9b,$03,$15,$b6,$55,$00,$82,$ad,$55,$07, 
    $0d,$55,$aa,$00,$18,$a5,$b5,$00,$85,$a5,$75,$05,$0f,$52,$b6,$00, 
    $1b,$69,$37,$00,$89,$e9,$37,$04,$13,$74,$97,$00,$81,$ea,$96,$08, 
    $0c,$6d,$52,$00,$16,$2d,$aa,$00,$83,$4b,$6a,$06,$0e,$a5,$6d,$00, 
    $1a,$d2,$6e,$00,$87,$d2,$5e,$04,$12,$e9,$2e,$00,$1d,$ec,$96,$0a, 
    $0b,$da,$95,$00,$15,$5b,$52,$00,$82,$56,$d2,$06,$0c,$2a,$da,$00, 
    $18,$a4,$dd,$00,$85,$a4,$bd,$05,$10,$d2,$5d,$00,$1b,$d9,$2d,$00, 
    $89,$b5,$2b,$03,$14,$ba,$95,$00,$81,$b5,$95,$08,$0b,$56,$b2,$00, 
    $16,$2a,$da,$00,$83,$49,$b6,$05,$0e,$64,$bb,$00,$19,$b2,$5b,$00, 
    $87,$6a,$57,$04,$12,$75,$2b,$00,$1d,$b6,$95,$00,$8a,$ad,$55,$02, 
    $15,$55,$aa,$00,$82,$55,$6c,$07,$0d,$c9,$76,$00,$17,$64,$b7,$00, 
    $86,$e4,$ae,$05,$11,$ea,$56,$00,$1b,$6d,$2a,$00,$88,$5a,$aa,$04, 
    $14,$ad,$55,$00,$81,$aa,$d5,$09,$0b,$52,$ea,$00,$16,$a9,$6d,$00, 
    $84,$a9,$5d,$06,$0f,$d4,$ae,$00,$1a,$ea,$4d,$00,$87,$ba,$55,$04, 
    $12,$5a,$aa,$00,$1d,$ab,$55,$00,$8a,$a6,$d5,$02,$14,$52,$da,$00, 
    $82,$52,$ba,$06,$0d,$a9,$3b,$00,$18,$b4,$9b,$00,$85,$74,$9b,$05, 
    $11,$b5,$4d,$00,$1c,$d6,$a9,$00,$88,$35,$aa,$03,$13,$a5,$b5,$00, 
    $81,$a5,$75,$0b,$0b,$52,$b6,$00,$16,$69,$37,$00,$84,$e9,$2f,$06, 
    $10,$f4,$97,$00,$1a,$75,$4b,$00,$87,$6d,$52,$05,$11,$2d,$69,$00, 
    $1d,$95,$b5,$00,$8a,$a5,$6d,$02,$15,$d2,$6e,$00,$82,$d2,$5e,$07, 
    $0e,$e9,$2e,$00,$19,$ea,$96,$00,$86,$da,$95,$05,$10,$5b,$4a,$00, 
    $1c,$ab,$69,$00,$88,$2a,$d8,$03); 

  function CnMonthOfDate(Date: TDate): String;//指定日期的农历月 
  function CnDayOfDate(Date: TDate): String;//指定日期的农历日 
  function CnDateOfDateStr(Date: TDate): String;//指定日期的农历日期 

implementation 

//日期是该年的第几天,1月1日为第一天 
function DaysNumberOfDate(Date: TDate): Integer; 
var 
  DaysNumber: Integer; 
  I: Integer; 
  yyyy, mm, dd: Word; 
begin 
  DecodeDate(Date, yyyy, mm, dd); 
  DaysNumber := 0; 
  for I := 1 to mm - 1 do 
    Inc(DaysNumber, MonthDays[IsLeapYear(yyyy), I]); 
  Inc(DaysNumber, dd); 
  Result := DaysNumber; 
end; 

//日期的农历日期,返回农历格式:月份*100 + 日,负数为闰月 
//超出范围则返回0 
function CnDateOfDate(Date: TDate): Integer; 
var 
  CnMonth, CnMonthDays: array[0..15] of Integer; 

  CnBeginDay, LeapMonth: Integer; 
  yyyy, mm, dd: Word; 
  Bytes: array[0..3] of Byte; 
  I: Integer; 
  CnMonthData: Word; 
  DaysCount, CnDaysCount, ResultMonth, ResultDay: Integer; 
begin 
  DecodeDate(Date, yyyy, mm, dd); 
  if (yyyy < 1901) or (yyyy > 2050) then 
  begin 
    Result := 0; 
    Exit; 
  end; 
  Bytes[0] := CnData[(yyyy - 1901) * 4]; 
  Bytes[1] := CnData[(yyyy - 1901) * 4 + 1]; 
  Bytes[2] := CnData[(yyyy - 1901) * 4 + 2]; 
  Bytes[3] := CnData[(yyyy - 1901) * 4 + 3]; 
  if (Bytes[0] and $80) <> 0 then CnMonth[0] := 12 
  else CnMonth[0] := 11; 
  CnBeginDay := (Bytes[0] and $7f); 
  CnMonthData := Bytes[1]; 
  CnMonthData := CnMonthData shl 8; 
  CnMonthData := CnMonthData or Bytes[2]; 
  LeapMonth := Bytes[3]; 

  for I := 15 downto 0 do 
  begin 
    CnMonthDays[15 - I] := 29; 
    if ((1 shl I) and CnMonthData) <> 0 then 
      Inc(CnMonthDays[15 - I]); 
    if CnMonth[15 - I] = LeapMonth then 
      CnMonth[15 - I + 1] := - LeapMonth 
    else 
    begin 
      if CnMonth[15 - I] < 0 then //上月为闰月
CnMonth[15 - I + 1] := - CnMonth[15 - I] + 1
else CnMonth[15 - I + 1] := CnMonth[15 - I] + 1;
if CnMonth[15 - I + 1] > 12 then CnMonth[15 - I + 1] := 1; 
    end; 
  end; 

  DaysCount := DaysNumberOfDate(Date) - 1; 
  if DaysCount <= (CnMonthDays[0] - CnBeginDay) then
begin
if (yyyy > 1901) and 
      (CnDateOfDate(EncodeDate(yyyy - 1, 12, 31)) < 0) then
ResultMonth := - CnMonth[0]
else ResultMonth := CnMonth[0];
ResultDay := CnBeginDay + DaysCount;
end
else
begin
CnDaysCount := CnMonthDays[0] - CnBeginDay;
I := 1;
while (CnDaysCount < DaysCount) and
(CnDaysCount + CnMonthDays[I] < DaysCount) do
begin
Inc(CnDaysCount, CnMonthDays[I]);
Inc(I);
end;
ResultMonth := CnMonth[I];
ResultDay := DaysCount - CnDaysCount;
end;
if ResultMonth > 0 then 
    Result := ResultMonth * 100 + ResultDay 
  else Result := ResultMonth * 100 - ResultDay 
end; 

function CnMonthOfDate(Date: TDate): String; 
const 
  CnMonthStr: array[1..12] of String = ( 
    '一', '二', '三', '四', '五', '六', '七', '八', '九', '十', 
    '冬', '蜡'); 
var 
  Month: Integer; 
begin 
  Month := CnDateOfDate(Date) div 100; 
  if Month < 0 then Result := '闰' + CnMonthStr[-Month]
else Result := CnMonthStr[Month] + '月';
end;

function CnDayOfDate(Date: TDate): String;
const
CnDayStr: array[1..30] of String = (
'初一', '初二', '初三', '初四', '初五',
'初六', '初七', '初八', '初九', '初十',
'十一', '十二', '十三', '十四', '十五',
'十六', '十七', '十八', '十九', '二十',
'廿一', '廿二', '廿三', '廿四', '廿五',
'廿六', '廿七', '廿八', '廿九', '三十');
var
Day: Integer;
begin
Day := Abs(CnDateOfDate(Date)) mod 100;
Result := CnDayStr[Day];
end;

function CnDateOfDateStr(Date: TDate): String;
begin
Result := CnMonthOfDate(Date) + CnDayOfDate(Date);
end;

end.

*************
{
這是一個國曆與農曆互相轉的Unit.

其中年份皆用民國年份, 請自行轉換 (西元年-1911 = 民國年).
***************************************************************************
*國農曆對映表之說明 : *
***************************************************************************
* 前二數字 = 閏月月份, 如果為 13 則沒有閏月 *
* 第三至第六數字 = 12 個月之大小月之2進位碼->10進位                      * 
   *  例如:                                                                  * 
   *       101010101010 = 2730                                               * 
   *       1 : 代表大月(30天) 0 : 代表小月(29天) ==> 1月大2月小3月大.....    * 
   *  第七位數字為閏月天數                                                   * 
   *           0 : 沒有閏月之天數                                            * 
   *           1 : 閏月為小月(29天)                                          * 
   *           2 : 閏月為大月(30天)                                          * 
   *  最後2位數字代表陽曆之1月1日與陰曆之1月1日相差天數                      * 
   *************************************************************************** 
   這對映表只有民國一年至民國一百年, 如不敷您的使用請按照上述之方式自行增加. 

   這個程式沒有判斷您所輸入之年,月,日是否正確, 請自行判斷. 

   如果轉換出來之農曆的月份是閏月則傳給您的值是***負數*** 
   如果農曆要轉換國曆如果是閏月請輸入***負數*** 

   此版本為FreeWare   Version : 0.1 
   您可以自行修改, 但最好可以將修改過之程式Mail一份給我. 
   如果您要用於商業用途, 請mail給我告知您的用途及原因. 

   作者 : 彭宏傑 
   E-Mail : [email protected] 


unit Lunar; 

interface 

uses SysUtils; 

//國曆轉農曆(民國年, 月, 日, var 農曆年, 農曆月, 農曆日)  
procedure Solar2Lunar(SYear, SMonth, SDay : Integer; Var LYear, LMonth, LDay : Integer); 
//農曆轉國曆(農曆年, 農曆月, 農曆日, var 民國年, 月, 日) 
procedure Lunar2Solar(LYear, LMonth, LDay : Integer; Var SYear, SMonth, SDay : Integer); 
//輸入農曆年份換算六十甲子名稱 
function YearName(LYear : integer) : string; 
//得知農曆之月份天數 
function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer; 

implementation 
const 
SMDay : array[1..12] of integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); 
c1 : array[1..10] of string[2] = ('甲', '乙', '丙', '丁', '戊', '己', '庚', '辛', '壬', '癸'); 
c2 : array[1..12] of string[2] = ('子', '丑', '寅', '卯', '辰', '巳', '午', '未', '申', '酉', '戌', '亥'); 

// Magic String : 
LongLife : array[1..111] of string[9] = ( 
'132637048', '133365036', '053365225', '132900044', '131386034', '022778122', //6 
'132395041', '071175231', '131175050', '132635038', '052891127', '131701046', //12 
'131748035', '042741223', '130694043', '132391032', '021327122', '131175040', //18 
'061623129', '133402047', '133402036', '051769125', '131453044', '130694034', //24 
'032158223', '132350041', '073213230', '133221049', '133402038', '063466226', //30 
'132901045', '131130035', '042651224', '130605043', '132349032', '023371121', //36 
'132709040', '072901128', '131738047', '132901036', '051333226', '131210044', //42 
'132651033', '031111223', '131323042', '082714130', '133733048', '131706038', //48 
'062794127', '132741045', '131206035', '042734124', '132647043', '131318032', //54 
'033878120', '133477039', '071461129', '131386047', '132413036', '051245126', //60 
'131197045', '132637033', '043405122', '133365041', '083413130', '132900048', //66 
'132922037', '062394227', '132395046', '131179035', '042711124', '132635043', //72 
'102855132', '131701050', '131748039', '062804128', '132742047', '132359036', //78 
'051199126', '131175045', '131611034', '031866122', '133749040', '081717130', //84 
'131452049', '132742037', '052413127', '132350046', '133222035', '043477123', //90 
'133402042', '133493031', '021877121', '131386039', '072747128', '130605048', //96 
'132349037', '053243125', '132709044', '132890033', '042986122', '132901040', //102 
'091373130', '131210049', '132651038', '061303127', '131323046', '132707035', //108 
'041941124', '131706042', '132773031');                                       //111 

var 
  LMDay : array[1..13] of integer; 
  InterMonth, InterMonthDays, SLRangeDay : integer; 


function IsLeapYear(AYear: Integer): Boolean; 
begin 
  Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0)); 
end; 

function YearName(LYear : integer) : string; 
var 
   x, y, ya : integer; 
begin 
     ya := LYear; 
     if ya < 1 then
ya := ya + 1;
if ya < 12 then
ya := ya + 60;
x := (ya + 8 - ((ya + 7) div 10) * 10);
y := (ya - ((ya-1) div 12) * 12);
result := c1[x]+c2[y];
end;

procedure CovertLunarMonth(magicno : integer);
var
i, size, m : integer;
begin
m := magicno;
for i := 12 downto 1 do begin
size := m mod 2;
if size = 0 then
LMDay[i] := 29
else
LMDay[i] := 30;
m := m div 2;
end;
end;

procedure ProcessMagicStr(yy : integer);
var
magicstr : string;
dsize, LunarMonth : integer;
begin
magicstr := LongLife[yy];
InterMonth := StrToInt(Copy(magicstr, 1, 2));
LunarMonth := StrToInt(copy(magicstr, 3, 4));
CovertLunarMonth(LunarMonth);
dsize := StrToInt(Copy(magicstr, 7, 1));
case dsize of
0 : InterMonthDays := 0;
1 : InterMonthDays := 29;
2 : InterMonthDays := 30;
end;
SLRangeDay := StrToInt(Copy(Magicstr, 8, 2));
end;

function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;
begin
ProcessMagicStr(LYear);
if LMonth < 0 then
Result := InterMonthDays
else
Result := LMDay[LMonth];
end;

procedure Solar2Lunar(SYear, SMonth, SDay : integer; var LYear, LMonth, LDay : integer);
var
i, day : integer;
begin
day := 0;
if isLeapYear(SYear+1911) then
SMDay[2] := 29;
ProcessMagicStr(SYear);
if SMonth = 1 then
day := SDay
else begin
for i := 1 to SMonth-1 do
day := day + SMDay[i];
day := day + SDay;
end;
if day <= SLRangeDay then begin
day := day - SLRangeDay;
processmagicstr(SYear-1);
for i := 12 downto 1 do begin
day := day + LMDay[i];
if day > 0 then 
               break; 
        end; 
        LYear := SYear - 1; 
        LMonth := i; 
        LDay := day; 
     end else begin 
        day := day - SLRangeDay; 
        for i := 1 to InterMonth-1 do begin 
            day := day - LMDay[i]; 
            if day <= 0 then
break;
end;
if day <= 0 then begin
LYear := SYear;
LMonth := i;
LDay := day + LMDay[i];
end else begin
day := day - LMDay[InterMonth];
if day <= 0 then begin
LYear := SYear;
LMonth := InterMonth;
LDay := day + LMDay[InterMonth];
end else begin
LMDay[InterMonth] := InterMonthDays;
for i := InterMonth to 12 do begin
day := day - LMDay[i];
if day <= 0 then
break;
end;
if i = InterMonth then
LMonth := 0 - InterMonth
else
LMonth := i;
LYear := SYear;
LDay := day + LMDay[i];
end;
end;
end;
end;

procedure Lunar2Solar(LYear, LMonth, LDay : integer; var SYear, SMonth, SDay : integer);
var
i, day : integer;
begin
day := 0;
SYear := LYear;
if isLeapYear(SYear+1911) then
SMDay[2] := 29;
processmagicstr(SYear);
if LMonth < 0 then
day := LMDay[InterMonth];
if LMonth <> 1 then 
        for i := 1 to LMonth-1 do 
            day := day + LMDay[i]; 
     day := day + LDay + SLRangeDay; 
     if (InterMonth <> 13) and (InterMonth < LMonth) then
day := day + InterMonthDays;
for i := 1 to 12 do begin
day := day - SMDay[i];
if day <= 0 then
break;
end;
if day > 0 then begin 
        SYear := SYear + 1; 
        if isLeapYear(SYear+1911) then 
           SMDay[2] := 29; 
        for i := 1 to 12 do begin 
            day := day - SMDay[i]; 
            if day <= 0 then
break;
end;
end;
//i := i - 1;
day := day + SMDay[i];
//if i = 0 then begin
// i := 12;
// SYear := SYear - 1;
// day := day + 31;
//end;// else
//day := day + SMDay[i];
SMonth := i;
SDay := day;
end;

end.







----

[关闭][返回]