本文整理自网络，侵删。
uses DateUtils ;
procedure TForm1.FormCreate(Sender: TObject);begincaption:=CnDayOfDate(Now());showmessage(CnDateOfDateStr(Now));end;
//单元文件：unit DateCn;
interface
uses Windows, SysUtils;
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;varDaysNumber: Integer;I: Integer;yyyy, mm, dd: Word;beginDecodeDate(Date, yyyy, mm, dd);DaysNumber := 0;for I := 1 to mm - 1 doInc(DaysNumber, MonthDays[IsLeapYear(yyyy), I]);Inc(DaysNumber, dd);Result := DaysNumber;end;
//日期的农历日期，返回农历格式：月份*100 + 日，负数为闰月//超出范围则返回0function CnDateOfDate(Date: TDate): Integer;varCnMonth, 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;beginDecodeDate(Date, yyyy, mm, dd);if (yyyy < 1901) or (yyyy > 2050) thenbeginResult := 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] := 12else 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 dobeginCnMonthDays[15 - I] := 29;if ((1 shl I) and CnMonthData) <> 0 thenInc(CnMonthDays[15 - I]);if CnMonth[15 - I] = LeapMonth thenCnMonth[15 - I + 1] := - LeapMonthelsebeginif CnMonth[15 - I] < 0 then //上月为闰月CnMonth[15 - I + 1] := - CnMonth[15 - I] + 1else 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) thenbeginif (yyyy > 1901) and(CnDateOfDate(EncodeDate(yyyy - 1, 12, 31)) < 0) thenResultMonth := - CnMonth[0]else ResultMonth := CnMonth[0];ResultDay := CnBeginDay + DaysCount;endelsebeginCnDaysCount := CnMonthDays[0] - CnBeginDay;I := 1;while (CnDaysCount < DaysCount) and(CnDaysCount + CnMonthDays[I] < DaysCount) dobeginInc(CnDaysCount, CnMonthDays[I]);Inc(I);end;ResultMonth := CnMonth[I];ResultDay := DaysCount - CnDaysCount;end;if ResultMonth > 0 thenResult := ResultMonth * 100 + ResultDayelse Result := ResultMonth * 100 - ResultDayend;
function CnMonthOfDate(Date: TDate): String;constCnMonthStr: array[1..12] of String = ('一', '二', '三', '四', '五', '六', '七', '八', '九', '十','冬', '蜡');varMonth: Integer;beginMonth := CnDateOfDate(Date) div 100;if Month < 0 then Result := '闰' + CnMonthStr[-Month]else Result := CnMonthStr[Month] + '月';end;
function CnDayOfDate(Date: TDate): String;constCnDayStr: array[1..30] of String = ('初一', '初二', '初三', '初四', '初五','初六', '初七', '初八', '初九', '初十','十一', '十二', '十三', '十四', '十五','十六', '十七', '十八', '十九', '二十','廿一', '廿二', '廿三', '廿四', '廿五','廿六', '廿七', '廿八', '廿九', '三十');varDay: Integer;beginDay := Abs(CnDateOfDate(Date)) mod 100;Result := CnDayStr[Day];end;
function CnDateOfDateStr(Date: TDate): String;beginResult := CnMonthOfDate(Date) + CnDayOfDate(Date);end;
end.
*************{?@是一?????雅c?r?鸦ハ噢D的Unit.
其中年份皆用民??年份, ?自行?D?Q (西元年-1911 = 民??年).****************************************************************************???r??τ潮碇??f明 : ***************************************************************************** 前二?底? = ?c月月份, 如果?? 13 ?t?]有?c月 ** 第三至第六?底? = 12 ??月之大小月之2?M位?a->10?M位 ** 例如: ** 101010101010 = 2730 ** 1 : 代表大月(30天) 0 : 代表小月(29天) ==> 1月大2月小3月大..... ** 第七位?底?殚c月天?? ** 0 : ?]有?c月之天?? ** 1 : ?c月?樾≡?(29天) ** 2 : ?c月?榇笤?(30天) ** 最後2位?底执?表??阎?1月1日?c??阎?1月1日相差天?? ****************************************************************************?@?τ潮碇挥忻??一年至民??一百年, 如不敷您的使用?按照上述之方式自行增加.
?@??程式?]有判?嗄?所?入之年,月,日是否正?_, ?自行判??.
如果?D?Q出?碇??r?训脑路菔情c月?t?鹘o您的值是***???***如果?r?岩??D?Q???讶绻?是?c月??入***???***
此版本??FreeWare Version : 0.1您可以自行修改, 但最好可以?⑿薷倪^之程式Mail一份?o我.如果您要用於商?I用途, ?mail?o我告知您的用途及原因.
作者 : 彭宏??E-Mail : rexpeng@ms1.hinet.net
}unit Lunar;
interface
uses SysUtils;
//???艳D?r??(民??年, 月, 日, var ?r?涯?, ?r?言?, ?r?讶?)procedure Solar2Lunar(SYear, SMonth, SDay : Integer; Var LYear, LMonth, LDay : Integer);//?r?艳D????(?r?涯?, ?r?言?, ?r?讶?, var 民??年, 月, 日)procedure Lunar2Solar(LYear, LMonth, LDay : Integer; Var SYear, SMonth, SDay : Integer);//?入?r?涯攴?Q算六十甲子名?Qfunction YearName(LYear : integer) : string;//得知?r?阎?月份天??function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;
implementationconstSMDay : 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
varLMDay : array[1..13] of integer;InterMonth, InterMonthDays, SLRangeDay : integer;
function IsLeapYear(AYear: Integer): Boolean;beginResult := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));end;
function YearName(LYear : integer) : string;varx, y, ya : integer;beginya := LYear;if ya < 1 thenya := ya + 1;if ya < 12 thenya := 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);vari, size, m : integer;beginm := magicno;for i := 12 downto 1 do beginsize := m mod 2;if size = 0 thenLMDay[i] := 29elseLMDay[i] := 30;m := m div 2;end;end;
procedure ProcessMagicStr(yy : integer);varmagicstr : string;dsize, LunarMonth : integer;beginmagicstr := LongLife[yy];InterMonth := StrToInt(Copy(magicstr, 1, 2));LunarMonth := StrToInt(copy(magicstr, 3, 4));CovertLunarMonth(LunarMonth);dsize := StrToInt(Copy(magicstr, 7, 1));case dsize of0 : InterMonthDays := 0;1 : InterMonthDays := 29;2 : InterMonthDays := 30;end;SLRangeDay := StrToInt(Copy(Magicstr, 8, 2));end;
function DaysPerLunarMonth(LYear, LMonth : Integer) : Integer;beginProcessMagicStr(LYear);if LMonth < 0 thenResult := InterMonthDayselseResult := LMDay[LMonth];end;
procedure Solar2Lunar(SYear, SMonth, SDay : integer; var LYear, LMonth, LDay : integer);vari, day : integer;beginday := 0;if isLeapYear(SYear+1911) thenSMDay[2] := 29;ProcessMagicStr(SYear);if SMonth = 1 thenday := SDayelse beginfor i := 1 to SMonth-1 doday := day + SMDay[i];day := day + SDay;end;if day <= SLRangeDay then beginday := day - SLRangeDay;processmagicstr(SYear-1);for i := 12 downto 1 do beginday := day + LMDay[i];if day > 0 thenbreak;end;LYear := SYear - 1;LMonth := i;LDay := day;end else beginday := day - SLRangeDay;for i := 1 to InterMonth-1 do beginday := day - LMDay[i];if day <= 0 thenbreak;end;if day <= 0 then beginLYear := SYear;LMonth := i;LDay := day + LMDay[i];end else beginday := day - LMDay[InterMonth];if day <= 0 then beginLYear := SYear;LMonth := InterMonth;LDay := day + LMDay[InterMonth];end else beginLMDay[InterMonth] := InterMonthDays;for i := InterMonth to 12 do beginday := day - LMDay[i];if day <= 0 thenbreak;end;if i = InterMonth thenLMonth := 0 - InterMonthelseLMonth := i;LYear := SYear;LDay := day + LMDay[i];end;end;end;end;
procedure Lunar2Solar(LYear, LMonth, LDay : integer; var SYear, SMonth, SDay : integer);vari, day : integer;beginday := 0;SYear := LYear;if isLeapYear(SYear+1911) thenSMDay[2] := 29;processmagicstr(SYear);if LMonth < 0 thenday := LMDay[InterMonth];if LMonth <> 1 thenfor i := 1 to LMonth-1 doday := day + LMDay[i];day := day + LDay + SLRangeDay;if (InterMonth <> 13) and (InterMonth < LMonth) thenday := day + InterMonthDays;for i := 1 to 12 do beginday := day - SMDay[i];if day <= 0 thenbreak;end;if day > 0 then beginSYear := SYear + 1;if isLeapYear(SYear+1911) thenSMDay[2] := 29;for i := 1 to 12 do beginday := day - SMDay[i];if day <= 0 thenbreak;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. 相关阅读 >>
Delphi xe andriod 文件后缀对应mime类型
Delphi 2009 新增单元 character isletter、isupper、islower、isdigit、isnumber
Delphi setwindowshookex - 设置钩子 unhookwindowshookex - 卸掉钩子
datasnap 上传/下载大文件(本demo以图传片文件为例)
更多相关阅读请进入《Delphi》频道 >>
