Z
zhoudang
Unregistered / Unconfirmed
GUEST, unregistred user!
谁有阳历和阴历的对照数据库？
或者阳历和阴历日期互换的程序如何写？
或者阳历和阴历日期互换的程序如何写？
您正在使用一款已经过时的浏览器！部分功能不能正常使用。
请尝试升级或使用 其他浏览器。
请尝试升级或使用 其他浏览器。
J
Jhdandcl
Unregistered / Unconfirmed
GUEST, unregistred user!
我听说，好像农历只能查表，不能用公式算的。
好像是历法设计上有问题。
csdn上的那个算法我贴在下面。
unit Calendar;
interface
uses SysUtils,Windows;
const
START_YEAR=1901;
END_YEAR=2050;
// ==> function IsLeapYear(Year: Word): Boolean;
file://计算iYear,iMonth,iDay对应是星期几 1年1月1日 --- 65535年12月31日
function WeekDay(iYear,iMonth,iDay:Word):Integer;
// ==> function DayOfWeek(Date: TDateTime): Integer;
file://计算指定日期的周数，周0为新年开始后第一个星期天开始的周
function WeekNum(const TDT:TDateTime):Word;overload;
function WeekNum(const iYear,iMonth,iDay:Word):Word;overload;
file://返回iYear年iMonth月的天数 1年1月 --- 65535年12月
function MonthDays(iYear,iMonth:Word):Word;
file://返回阴历iLunarYer年阴历iLunarMonth月的天数，如果iLunarMonth为闰月，
file://高字为第二个iLunarMonth月的天数，否则高字为0
// 1901年1月---2050年12月
function LunarMonthDays(iLunarYear,iLunarMonth:Word):Longword;
file://返回阴历iLunarYear年的总天数
// 1901年1月---2050年12月
function LunarYearDays(iLunarYear:Word):Word;
file://返回阴历iLunarYear年的闰月月份，如没有返回0
// 1901年1月---2050年12月
function GetLeapMonth(iLunarYear:Word):Word;
file://把iYear年格式化成天干记年法表示的字符串
procedure FormatLunarYear(iYear:Word;var pBuffer:string);overload;
function FormatLunarYear(iYear:Word):string;overload;
file://把iMonth格式化成中文字符串
procedure FormatMonth(iMonth:Word;var
pBuffer:string;bLunar:Boolean=True);overload;
function FormatMonth(iMonth:Word;bLunar:Boolean=True):string;overload;
file://把iDay格式化成中文字符串
procedure FormatLunarDay(iDay:Word;var pBuffer:string);overload;
function FormatLunarDay(iDay:Word):string;overload;
file://计算公历两个日期间相差的天数 1年1月1日 --- 65535年12月31日
function
CalcDateDiff(iEndYear,iEndMonth,iEndDay:Word;iStartYear:Word=START_YEAR;iSta
rtMonth:Word=1;iStartDay:Word=1):Longword;overload;
function CalcDateDiff(EndDate,StartDate:TDateTime):Longword;overload;
file://计算公历iYear年iMonth月iDay日对应的阴历日期,返回对应的阴历节气 0-24
file://1901年1月1日---2050年12月31日
function GetLunarDate(iYear,iMonth,iDay:Word;var
iLunarYear,iLunarMonth,iLunarDay:Word):Word;overload;
procedure GetLunarDate(InDate:TDateTime;var
iLunarYear,iLunarMonth,iLunarDay:Word);overload;
function GetLunarHolDay(InDate:TDateTime):string;overload;
function GetLunarHolDay(iYear,iMonth,iDay:Word):string;overload;
file://private function--------------------------------------
file://计算从1901年1月1日过iSpanDays天后的阴历日期
procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);
file://计算公历iYear年iMonth月iDay日对应的节气 0-24，0表不是节气
function l_GetLunarHolDay(iYear,iMonth,iDay:Word):Word;
implementation
var
file://数组gLunarDay存入阴历1901年到2100年每年中的月天数信息，
file://阴历每月只能是29或30天，一年用12（或13）个二进制位表示，对应位为1表30天，
否则为29天
gLunarMonthDay:array[0..149] of Word=(
file://测试数据只有1901.1.1 --2050.12.31
$4ae0, $a570, $5268, $d260, $d950, $6aa8, $56a0, $9ad0, $4ae8, $4ae0,
file://1910
$a4d8, $a4d0, $d250, $d548, $b550, $56a0, $96d0, $95b0, $49b8, $49b0,
file://1920
$a4b0, $b258, $6a50, $6d40, $ada8, $2b60, $9570, $4978, $4970, $64b0,
file://1930
$d4a0, $ea50, $6d48, $5ad0, $2b60, $9370, $92e0, $c968, $c950, $d4a0,
file://1940
$da50, $b550, $56a0, $aad8, $25d0, $92d0, $c958, $a950, $b4a8, $6ca0,
file://1950
$b550, $55a8, $4da0, $a5b0, $52b8, $52b0, $a950, $e950, $6aa0, $ad50,
file://1960
$ab50, $4b60, $a570, $a570, $5260, $e930, $d950, $5aa8, $56a0, $96d0,
file://1970
$4ae8, $4ad0, $a4d0, $d268, $d250, $d528, $b540, $b6a0, $96d0, $95b0,
file://1980
$49b0, $a4b8, $a4b0, $b258, $6a50, $6d40, $ada0, $ab60, $9370, $4978,
file://1990
$4970, $64b0, $6a50, $ea50, $6b28, $5ac0, $ab60, $9368, $92e0, $c960,
file://2000
$d4a8, $d4a0, $da50, $5aa8, $56a0, $aad8, $25d0, $92d0, $c958, $a950,
file://2010
$b4a0, $b550, $b550, $55a8, $4ba0, $a5b0, $52b8, $52b0, $a930, $74a8,
file://2020
$6aa0, $ad50, $4da8, $4b60, $9570, $a4e0, $d260, $e930, $d530, $5aa0,
file://2030
$6b50, $96d0, $4ae8, $4ad0, $a4d0, $d258, $d250, $d520, $daa0, $b5a0,
file://2040
$56d0, $4ad8, $49b0, $a4b8, $a4b0, $aa50, $b528, $6d20, $ada0, $55b0);
file://2050
file://数组gLanarMonth存放阴历1901年到2050年闰月的月份，如没有则为0，每字节存两年
gLunarMonth:array[0..74] of Byte=(
$00, $50, $04, $00, $20, file://1910
$60, $05, $00, $20, $70, file://1920
$05, $00, $40, $02, $06, file://1930
$00, $50, $03, $07, $00, file://1940
$60, $04, $00, $20, $70, file://1950
$05, $00, $30, $80, $06, file://1960
$00, $40, $03, $07, $00, file://1970
$50, $04, $08, $00, $60, file://1980
$04, $0a, $00, $60, $05, file://1990
$00, $30, $80, $05, $00, file://2000
$40, $02, $07, $00, $50, file://2010
$04, $09, $00, $60, $04, file://2020
$00, $20, $60, $05, $00, file://2030
$30, $b0, $06, $00, $50, file://2040
$02, $07, $00, $50, $03); file://2050
file://数组gLanarHoliDay存放每年的二十四节气对应的阳历日期
file://每年的二十四节气对应的阳历日期几乎固定，平均分布于十二个月中
// 1月 2月 3月 4月 5月 6月
file://小寒 大寒 立春 雨水 惊蛰 春分 清明 谷雨 立夏 小满 芒种 夏至
// 7月 8月 9月 10月 11月 12月
file://小暑 大暑 立秋 处暑 白露 秋分 寒露 霜降 立冬 小雪 大雪 冬至
{***************************************************************************
******
节气无任何确定规律,所以只好存表,要节省空间,所以....
****************************************************************************
******}
file://数据格式说明:
file://如1901年的节气为
// 1月 2月 3月 4月 5月 6月 7月 8月 9月 10月 11月
12月
// 6, 21, 4, 19, 6, 21, 5, 21, 6,22, 6,22, 8, 23, 8, 24, 8, 24, 8, 24, 8,
23, 8, 22
// 9, 6, 11,4, 9, 6, 10,6, 9,7, 9,7, 7, 8, 7, 9, 7, 9, 7, 9, 7,
8, 7, 15
file://上面第一行数据为每月节气对应日期,15减去每月第一个节气,每月第二个节气减去15
得第二行
// 这样每月两个节气对应数据都小于16,每月用一个字节存放,高位存放第一个节气数
据,低位存放
file://第二个节气的数据,可得下表
gLunarHolDay:array[0..1799] of Byte=(
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1901
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, file://1902
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, file://1903
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, file://1904
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1905
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1906
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, file://1907
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1908
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1909
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1910
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, file://1911
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1912
$95, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1913
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, file://1914
$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, file://1915
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1916
$95, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $87, file://1917
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, file://1918
$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, file://1919
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1920
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, file://1921
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, file://1922
$96, $A4, $96, $96, $97, $87, $79, $79, $69, $69, $78, $78, file://1923
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1924
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, file://1925
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1926
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, file://1927
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1928
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1929
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1930
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, file://1931
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1932
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1933
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1934
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1935
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1936
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1937
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1938
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1939
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1940
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1941
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1942
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1943
$96, $A5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, file://1944
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1945
$95, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, file://1946
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, file://1947
$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1948
$A5, $B4, $96, $A5, $96, $97, $88, $79, $78, $79, $77, $87, file://1949
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, file://1950
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, file://1951
$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1952
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1953
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $68, $78, $87, file://1954
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1955
$96, $A5, $A5, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1956
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1957
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1958
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1959
$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1960
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1961
$96, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1962
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1963
$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1964
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1965
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1966
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1967
$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1968
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1969
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1970
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1971
$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1972
$A5, $B5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, file://1973
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1974
$96, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, file://1975
$96, $A4, $A5, $B5, $A6, $A6, $88, $89, $88, $78, $87, $87, file://1976
$A5, $B4, $96, $A5, $96, $96, $88, $88, $78, $78, $87, $87, file://1977
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, file://1978
$96, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $77, file://1979
$96, $A4, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1980
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $77, $87, file://1981
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1982
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, file://1983
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://1984
$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1985
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1986
$95, $B4, $96, $A5, $96, $97, $88, $79, $78, $69, $78, $87, file://1987
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://1988
$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1989
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, file://1990
$95, $B4, $96, $A5, $86, $97, $88, $78, $78, $69, $78, $87, file://1991
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://1992
$A5, $B3, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1993
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1994
$95, $B4, $96, $A5, $96, $97, $88, $76, $78, $69, $78, $87, file://1995
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://1996
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1997
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1998
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1999
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2000
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2001
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://2002
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://2003
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2004
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2005
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2006
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://2007
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $87, $78, $87, $86, file://2008
$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2009
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2010
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, file://2011
$96, $B4, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2012
$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://2013
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2014
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://2015
$95, $B4, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2016
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://2017
$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2018
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, file://2019
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $86, file://2020
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2021
$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://2022
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, file://2023
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2024
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2025
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2026
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://2027
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2028
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2029
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2030
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://2031
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2032
$A5, $C3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $86, file://2033
$A5, $B3, $A5, $A5, $A6, $A6, $88, $78, $88, $78, $87, $87, file://2034
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2035
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2036
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2037
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2038
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2039
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2040
$A5, $C3, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2041
$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2042
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2043
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $88, $87, $96, file://2044
$A5, $C3, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2045
$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://2046
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2047
$95, $B4, $A5, $B4, $A5, $A5, $97, $87, $87, $88, $86, $96, file://2048
$A4, $C3, $A5, $A5, $A5, $A6, $97, $87, $87, $78, $87, $86, file://2049
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $78, $78, $87, $87); file://2050
function WeekDay(iYear,iMonth,iDay:Word):Integer;
begin
Result:=DayOfWeek(EncodeDate(iYear,iMonth,iDay));
end;
function WeekNum(const TDT:TDateTime):Word;
var
Y,M,D:Word;
dtTmp:TDateTime;
begin
DecodeDate(TDT,Y,M,D);
dtTmp:=EnCodeDate(Y,1,1);
Result:=(Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) div 7;
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:Wor
d;iStartDay:Word):Longword;
begin
Result:=Trunc(EncodeDate(iEndYear,iEndMonth,iEndDay)-EncodeDate(iStartYear,i
StartMonth,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,i
Day));
Result:=l_GetLunarHolDay(iYear,iMonth,iDay);
end;
procedure GetLunarDate(InDate:TDateTime;var
iLunarYear,iLunarMonth,iLunarDay:Word);
begin
l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(InDate,EncodeD
ate(START_YEAR,1,1)));
end;
procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);
var
tmp:Longword;
begin
file://阳历1901年2月19日为阴历1901年正月初一
file://阳历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;
file://下面从阴历1901年正月初一算起
iSpanDays:=iSpanDays-49;
iYear:=START_YEAR;
iMonth:=1;
iDay:=1;
file://计算年
tmp:=LunarYearDays(iYear);
while iSpanDays>=tmp do
begin
iSpanDays:=iSpanDays-tmp;
Inc(iYear);
tmp:=LunarYearDays(iYear);
end;
file://计算月
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;
file://计算日
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;
end.
好像是历法设计上有问题。
csdn上的那个算法我贴在下面。
unit Calendar;
interface
uses SysUtils,Windows;
const
START_YEAR=1901;
END_YEAR=2050;
// ==> function IsLeapYear(Year: Word): Boolean;
file://计算iYear,iMonth,iDay对应是星期几 1年1月1日 --- 65535年12月31日
function WeekDay(iYear,iMonth,iDay:Word):Integer;
// ==> function DayOfWeek(Date: TDateTime): Integer;
file://计算指定日期的周数，周0为新年开始后第一个星期天开始的周
function WeekNum(const TDT:TDateTime):Word;overload;
function WeekNum(const iYear,iMonth,iDay:Word):Word;overload;
file://返回iYear年iMonth月的天数 1年1月 --- 65535年12月
function MonthDays(iYear,iMonth:Word):Word;
file://返回阴历iLunarYer年阴历iLunarMonth月的天数，如果iLunarMonth为闰月，
file://高字为第二个iLunarMonth月的天数，否则高字为0
// 1901年1月---2050年12月
function LunarMonthDays(iLunarYear,iLunarMonth:Word):Longword;
file://返回阴历iLunarYear年的总天数
// 1901年1月---2050年12月
function LunarYearDays(iLunarYear:Word):Word;
file://返回阴历iLunarYear年的闰月月份，如没有返回0
// 1901年1月---2050年12月
function GetLeapMonth(iLunarYear:Word):Word;
file://把iYear年格式化成天干记年法表示的字符串
procedure FormatLunarYear(iYear:Word;var pBuffer:string);overload;
function FormatLunarYear(iYear:Word):string;overload;
file://把iMonth格式化成中文字符串
procedure FormatMonth(iMonth:Word;var
pBuffer:string;bLunar:Boolean=True);overload;
function FormatMonth(iMonth:Word;bLunar:Boolean=True):string;overload;
file://把iDay格式化成中文字符串
procedure FormatLunarDay(iDay:Word;var pBuffer:string);overload;
function FormatLunarDay(iDay:Word):string;overload;
file://计算公历两个日期间相差的天数 1年1月1日 --- 65535年12月31日
function
CalcDateDiff(iEndYear,iEndMonth,iEndDay:Word;iStartYear:Word=START_YEAR;iSta
rtMonth:Word=1;iStartDay:Word=1):Longword;overload;
function CalcDateDiff(EndDate,StartDate:TDateTime):Longword;overload;
file://计算公历iYear年iMonth月iDay日对应的阴历日期,返回对应的阴历节气 0-24
file://1901年1月1日---2050年12月31日
function GetLunarDate(iYear,iMonth,iDay:Word;var
iLunarYear,iLunarMonth,iLunarDay:Word):Word;overload;
procedure GetLunarDate(InDate:TDateTime;var
iLunarYear,iLunarMonth,iLunarDay:Word);overload;
function GetLunarHolDay(InDate:TDateTime):string;overload;
function GetLunarHolDay(iYear,iMonth,iDay:Word):string;overload;
file://private function--------------------------------------
file://计算从1901年1月1日过iSpanDays天后的阴历日期
procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);
file://计算公历iYear年iMonth月iDay日对应的节气 0-24，0表不是节气
function l_GetLunarHolDay(iYear,iMonth,iDay:Word):Word;
implementation
var
file://数组gLunarDay存入阴历1901年到2100年每年中的月天数信息，
file://阴历每月只能是29或30天，一年用12（或13）个二进制位表示，对应位为1表30天，
否则为29天
gLunarMonthDay:array[0..149] of Word=(
file://测试数据只有1901.1.1 --2050.12.31
$4ae0, $a570, $5268, $d260, $d950, $6aa8, $56a0, $9ad0, $4ae8, $4ae0,
file://1910
$a4d8, $a4d0, $d250, $d548, $b550, $56a0, $96d0, $95b0, $49b8, $49b0,
file://1920
$a4b0, $b258, $6a50, $6d40, $ada8, $2b60, $9570, $4978, $4970, $64b0,
file://1930
$d4a0, $ea50, $6d48, $5ad0, $2b60, $9370, $92e0, $c968, $c950, $d4a0,
file://1940
$da50, $b550, $56a0, $aad8, $25d0, $92d0, $c958, $a950, $b4a8, $6ca0,
file://1950
$b550, $55a8, $4da0, $a5b0, $52b8, $52b0, $a950, $e950, $6aa0, $ad50,
file://1960
$ab50, $4b60, $a570, $a570, $5260, $e930, $d950, $5aa8, $56a0, $96d0,
file://1970
$4ae8, $4ad0, $a4d0, $d268, $d250, $d528, $b540, $b6a0, $96d0, $95b0,
file://1980
$49b0, $a4b8, $a4b0, $b258, $6a50, $6d40, $ada0, $ab60, $9370, $4978,
file://1990
$4970, $64b0, $6a50, $ea50, $6b28, $5ac0, $ab60, $9368, $92e0, $c960,
file://2000
$d4a8, $d4a0, $da50, $5aa8, $56a0, $aad8, $25d0, $92d0, $c958, $a950,
file://2010
$b4a0, $b550, $b550, $55a8, $4ba0, $a5b0, $52b8, $52b0, $a930, $74a8,
file://2020
$6aa0, $ad50, $4da8, $4b60, $9570, $a4e0, $d260, $e930, $d530, $5aa0,
file://2030
$6b50, $96d0, $4ae8, $4ad0, $a4d0, $d258, $d250, $d520, $daa0, $b5a0,
file://2040
$56d0, $4ad8, $49b0, $a4b8, $a4b0, $aa50, $b528, $6d20, $ada0, $55b0);
file://2050
file://数组gLanarMonth存放阴历1901年到2050年闰月的月份，如没有则为0，每字节存两年
gLunarMonth:array[0..74] of Byte=(
$00, $50, $04, $00, $20, file://1910
$60, $05, $00, $20, $70, file://1920
$05, $00, $40, $02, $06, file://1930
$00, $50, $03, $07, $00, file://1940
$60, $04, $00, $20, $70, file://1950
$05, $00, $30, $80, $06, file://1960
$00, $40, $03, $07, $00, file://1970
$50, $04, $08, $00, $60, file://1980
$04, $0a, $00, $60, $05, file://1990
$00, $30, $80, $05, $00, file://2000
$40, $02, $07, $00, $50, file://2010
$04, $09, $00, $60, $04, file://2020
$00, $20, $60, $05, $00, file://2030
$30, $b0, $06, $00, $50, file://2040
$02, $07, $00, $50, $03); file://2050
file://数组gLanarHoliDay存放每年的二十四节气对应的阳历日期
file://每年的二十四节气对应的阳历日期几乎固定，平均分布于十二个月中
// 1月 2月 3月 4月 5月 6月
file://小寒 大寒 立春 雨水 惊蛰 春分 清明 谷雨 立夏 小满 芒种 夏至
// 7月 8月 9月 10月 11月 12月
file://小暑 大暑 立秋 处暑 白露 秋分 寒露 霜降 立冬 小雪 大雪 冬至
{***************************************************************************
******
节气无任何确定规律,所以只好存表,要节省空间,所以....
****************************************************************************
******}
file://数据格式说明:
file://如1901年的节气为
// 1月 2月 3月 4月 5月 6月 7月 8月 9月 10月 11月
12月
// 6, 21, 4, 19, 6, 21, 5, 21, 6,22, 6,22, 8, 23, 8, 24, 8, 24, 8, 24, 8,
23, 8, 22
// 9, 6, 11,4, 9, 6, 10,6, 9,7, 9,7, 7, 8, 7, 9, 7, 9, 7, 9, 7,
8, 7, 15
file://上面第一行数据为每月节气对应日期,15减去每月第一个节气,每月第二个节气减去15
得第二行
// 这样每月两个节气对应数据都小于16,每月用一个字节存放,高位存放第一个节气数
据,低位存放
file://第二个节气的数据,可得下表
gLunarHolDay:array[0..1799] of Byte=(
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1901
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, file://1902
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, file://1903
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, file://1904
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1905
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1906
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, file://1907
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1908
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1909
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1910
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, file://1911
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1912
$95, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1913
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, file://1914
$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, file://1915
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1916
$95, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $87, file://1917
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, file://1918
$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, file://1919
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1920
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, file://1921
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, file://1922
$96, $A4, $96, $96, $97, $87, $79, $79, $69, $69, $78, $78, file://1923
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1924
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, file://1925
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1926
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, file://1927
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1928
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1929
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1930
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, file://1931
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1932
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1933
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1934
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1935
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1936
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1937
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1938
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1939
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1940
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1941
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1942
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, file://1943
$96, $A5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, file://1944
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1945
$95, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, file://1946
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, file://1947
$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1948
$A5, $B4, $96, $A5, $96, $97, $88, $79, $78, $79, $77, $87, file://1949
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, file://1950
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, file://1951
$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1952
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1953
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $68, $78, $87, file://1954
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1955
$96, $A5, $A5, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1956
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1957
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1958
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1959
$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1960
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1961
$96, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1962
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1963
$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1964
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1965
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1966
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1967
$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1968
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1969
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1970
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, file://1971
$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1972
$A5, $B5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, file://1973
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1974
$96, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, file://1975
$96, $A4, $A5, $B5, $A6, $A6, $88, $89, $88, $78, $87, $87, file://1976
$A5, $B4, $96, $A5, $96, $96, $88, $88, $78, $78, $87, $87, file://1977
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, file://1978
$96, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $77, file://1979
$96, $A4, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1980
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $77, $87, file://1981
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1982
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, file://1983
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://1984
$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://1985
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://1986
$95, $B4, $96, $A5, $96, $97, $88, $79, $78, $69, $78, $87, file://1987
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://1988
$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1989
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, file://1990
$95, $B4, $96, $A5, $86, $97, $88, $78, $78, $69, $78, $87, file://1991
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://1992
$A5, $B3, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://1993
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1994
$95, $B4, $96, $A5, $96, $97, $88, $76, $78, $69, $78, $87, file://1995
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://1996
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://1997
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://1998
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://1999
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2000
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2001
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://2002
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://2003
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2004
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2005
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2006
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, file://2007
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $87, $78, $87, $86, file://2008
$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2009
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2010
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, file://2011
$96, $B4, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2012
$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://2013
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2014
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, file://2015
$95, $B4, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2016
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://2017
$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2018
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, file://2019
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $86, file://2020
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2021
$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, file://2022
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, file://2023
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2024
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2025
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2026
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://2027
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2028
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2029
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2030
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, file://2031
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2032
$A5, $C3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $86, file://2033
$A5, $B3, $A5, $A5, $A6, $A6, $88, $78, $88, $78, $87, $87, file://2034
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2035
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2036
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, file://2037
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2038
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2039
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, file://2040
$A5, $C3, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2041
$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, file://2042
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2043
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $88, $87, $96, file://2044
$A5, $C3, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, file://2045
$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, file://2046
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, file://2047
$95, $B4, $A5, $B4, $A5, $A5, $97, $87, $87, $88, $86, $96, file://2048
$A4, $C3, $A5, $A5, $A5, $A6, $97, $87, $87, $78, $87, $86, file://2049
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $78, $78, $87, $87); file://2050
function WeekDay(iYear,iMonth,iDay:Word):Integer;
begin
Result:=DayOfWeek(EncodeDate(iYear,iMonth,iDay));
end;
function WeekNum(const TDT:TDateTime):Word;
var
Y,M,D:Word;
dtTmp:TDateTime;
begin
DecodeDate(TDT,Y,M,D);
dtTmp:=EnCodeDate(Y,1,1);
Result:=(Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) div 7;
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:Wor
d;iStartDay:Word):Longword;
begin
Result:=Trunc(EncodeDate(iEndYear,iEndMonth,iEndDay)-EncodeDate(iStartYear,i
StartMonth,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,i
Day));
Result:=l_GetLunarHolDay(iYear,iMonth,iDay);
end;
procedure GetLunarDate(InDate:TDateTime;var
iLunarYear,iLunarMonth,iLunarDay:Word);
begin
l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(InDate,EncodeD
ate(START_YEAR,1,1)));
end;
procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);
var
tmp:Longword;
begin
file://阳历1901年2月19日为阴历1901年正月初一
file://阳历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;
file://下面从阴历1901年正月初一算起
iSpanDays:=iSpanDays-49;
iYear:=START_YEAR;
iMonth:=1;
iDay:=1;
file://计算年
tmp:=LunarYearDays(iYear);
while iSpanDays>=tmp do
begin
iSpanDays:=iSpanDays-tmp;
Inc(iYear);
tmp:=LunarYearDays(iYear);
end;
file://计算月
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;
file://计算日
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;
end.
我
我爱PASCAL
Unregistered / Unconfirmed
GUEST, unregistred user!
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日
//第四字节为闰月月份
// BaseDate='2000/02/04';//2000立春
BaseAnimalDate = '1972'; //1972年支为子(是鼠年)
BaseSkyStemDate = '1974'; //1974年干为甲
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 DaysNumberOfDate(Date: TDate): Integer;
//日期是该年的第几天，1月1日为第一天
function CnMonthOfDate(Date: TDate): string; //指定日期的农历月
function CnDayOfDate(Date: TDate): string; //指定日期的农历日包括节日
function CnDateOfDateStr(Date: TDate): string; //指定日期的农历日期
function CnDayOfDatePH(Date: TDate): string; //指定日期的农历日
function CnDateOfDateStrPH(Date: TDate): string; //指定日期的农历日期包括节日
function CnDayOfDateJr(Date: TDate): string; //只有节日
function CnanimalOfYear(Date: TDate): string; //返回十二生肖(地支)
function CnSkyStemOfYear(Date: TDate): string; //返回十大天干
function CnDateOfDate(Date: TDate): Integer;
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 < DaysCount) do
begin
Inc(CnDaysCount, CnMonthDays);
Inc(I);
end;
ResultMonth := CnMonth;
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 CnDayOfDatePH(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) + CnDayOfDatePH(Date);
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];
{ if (CnMonthOfDate(Date) = '正月') then
case Day of
1: Result := '春节';
15: Result := '元宵节';
else
Result := CnDayStr[Day];
end
else
begin
case Day of
5:
if CnMonthOfDate(Date) = '五月' then
Result := '端午节'
else
Result := CnDayStr[Day];
7:
if CnMonthOfDate(Date) = '七月' then
Result := '七夕节'
else
Result := CnDayStr[Day];
15:
if CnMonthOfDate(Date) = '八月' then
Result := '中秋节'
else
Result := CnDayStr[Day];
9:
if CnMonthOfDate(Date) = '九月' then
Result := '重阳节'
else
Result := CnDayStr[Day];
8:
if CnMonthOfDate(Date) = '腊月' then
Result := '腊八节'
else
Result := CnDayStr[Day];
else
if (CnMonthOfDate(Date + 1) = '正月') then
Result := '除夕'
else
Result := CnDayStr[Day];
end;
end; }
end;
function CnDateOfDateStrPH(Date: TDate): string;
begin
Result := CnMonthOfDate(Date) + CnDayOfDate(Date);
end;
function CnDayOfDateJr(Date: TDate): string;
const
CnDayStr: array[1..30] of string = (
'初一', '初二', '初三', '初四', '初五',
'初六', '初七', '初八', '初九', '初十',
'十一', '十二', '十三', '十四', '十五',
'十六', '十七', '十八', '十九', '二十',
'廿一', '廿二', '廿三', '廿四', '廿五',
'廿六', '廿七', '廿八', '廿九', '三十');
var
Day: Integer;
begin
Day := Abs(CnDateOfDate(Date)) mod 100;
if (CnMonthOfDate(Date) = '正月') then
case Day of
1: Result := '春节';
15: Result := '元宵节';
else
Result := '';
end
else
begin
case Day of
5:
if CnMonthOfDate(Date) = '五月' then
Result := '端午节'
else
Result := '';
7:
if CnMonthOfDate(Date) = '七月' then
Result := '七夕节'
else
Result := '';
15:
if CnMonthOfDate(Date) = '八月' then
Result := '中秋节'
else
Result := '';
9:
if CnMonthOfDate(Date) = '九月' then
Result := '重阳节'
else
Result := '';
8:
if CnMonthOfDate(Date) = '腊月' then
Result := '腊八节'
else
Result := '';
else
if (CnMonthOfDate(Date + 1) = '正月') then
Result := '除夕'
else
Result := '';
end; {case}
end;
end;
function CnanimalOfYear(Date: TDate): string; //返回十二生肖
begin
case (StrToInt(Copy(DateToStr(Date), 1, 4)) - StrToInt(BaseAnimalDate))
mod 12 of
0:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '子鼠'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '亥猪'
else
Result := '子鼠';
end;
1, -11:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '丑牛'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '子鼠'
else
Result := '丑牛';
end;
2, -10:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '寅虎'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '丑牛'
else
Result := '寅虎';
end;
3, -9:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '卯兔'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '寅虎'
else
Result := '卯兔';
end;
4, -8:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '辰龙'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '卯兔'
else
Result := '辰龙';
end;
5, -7:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '巳蛇'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '辰龙'
else
Result := '巳蛇';
end;
6, -6:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '午马'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '巳蛇'
else
Result := '午马';
end;
7, -5:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '未羊'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '午马'
else
Result := '未羊';
end;
8, -4:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '申猴'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '未羊'
else
Result := '申猴';
end;
9, -3:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '酉鸡'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '申猴'
else
Result := '酉鸡';
end;
10, -2:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '戌狗'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '酉鸡'
else
Result := '戌狗';
end;
11, -1:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '亥猪'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '戌狗'
else
Result := '亥猪';
end;
end; {case}
end;
function CnSkyStemOfYear(Date: TDate): string; //返回十大天干
begin
case (StrToInt(Copy(DateToStr(Date), 1, 4)) - StrToInt(BaseSkyStemDate))
mod 10 of
0:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '甲'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '癸'
else
Result := '甲';
end;
1, -9:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '乙'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '甲'
else
Result := '乙';
end;
2, -8:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '丙'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '乙'
else
Result := '丙';
end;
3, -7:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '丁'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '丙'
else
Result := '丁';
end;
4, -6:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '戊'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '丁'
else
Result := '戊';
end;
5, -5:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '巳'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '戊'
else
Result := '巳';
end;
6, -4:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '庚'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '巳'
else
Result := '庚';
end;
7, -3:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '辛'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '庚'
else
Result := '辛';
end;
8, -2:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '壬'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '辛'
else
Result := '壬';
end;
9, -1:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '癸'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '壬'
else
Result := '癸';
end;
end;
end;
end.
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日
//第四字节为闰月月份
// BaseDate='2000/02/04';//2000立春
BaseAnimalDate = '1972'; //1972年支为子(是鼠年)
BaseSkyStemDate = '1974'; //1974年干为甲
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 DaysNumberOfDate(Date: TDate): Integer;
//日期是该年的第几天，1月1日为第一天
function CnMonthOfDate(Date: TDate): string; //指定日期的农历月
function CnDayOfDate(Date: TDate): string; //指定日期的农历日包括节日
function CnDateOfDateStr(Date: TDate): string; //指定日期的农历日期
function CnDayOfDatePH(Date: TDate): string; //指定日期的农历日
function CnDateOfDateStrPH(Date: TDate): string; //指定日期的农历日期包括节日
function CnDayOfDateJr(Date: TDate): string; //只有节日
function CnanimalOfYear(Date: TDate): string; //返回十二生肖(地支)
function CnSkyStemOfYear(Date: TDate): string; //返回十大天干
function CnDateOfDate(Date: TDate): Integer;
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 < DaysCount) do
begin
Inc(CnDaysCount, CnMonthDays);
Inc(I);
end;
ResultMonth := CnMonth;
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 CnDayOfDatePH(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) + CnDayOfDatePH(Date);
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];
{ if (CnMonthOfDate(Date) = '正月') then
case Day of
1: Result := '春节';
15: Result := '元宵节';
else
Result := CnDayStr[Day];
end
else
begin
case Day of
5:
if CnMonthOfDate(Date) = '五月' then
Result := '端午节'
else
Result := CnDayStr[Day];
7:
if CnMonthOfDate(Date) = '七月' then
Result := '七夕节'
else
Result := CnDayStr[Day];
15:
if CnMonthOfDate(Date) = '八月' then
Result := '中秋节'
else
Result := CnDayStr[Day];
9:
if CnMonthOfDate(Date) = '九月' then
Result := '重阳节'
else
Result := CnDayStr[Day];
8:
if CnMonthOfDate(Date) = '腊月' then
Result := '腊八节'
else
Result := CnDayStr[Day];
else
if (CnMonthOfDate(Date + 1) = '正月') then
Result := '除夕'
else
Result := CnDayStr[Day];
end;
end; }
end;
function CnDateOfDateStrPH(Date: TDate): string;
begin
Result := CnMonthOfDate(Date) + CnDayOfDate(Date);
end;
function CnDayOfDateJr(Date: TDate): string;
const
CnDayStr: array[1..30] of string = (
'初一', '初二', '初三', '初四', '初五',
'初六', '初七', '初八', '初九', '初十',
'十一', '十二', '十三', '十四', '十五',
'十六', '十七', '十八', '十九', '二十',
'廿一', '廿二', '廿三', '廿四', '廿五',
'廿六', '廿七', '廿八', '廿九', '三十');
var
Day: Integer;
begin
Day := Abs(CnDateOfDate(Date)) mod 100;
if (CnMonthOfDate(Date) = '正月') then
case Day of
1: Result := '春节';
15: Result := '元宵节';
else
Result := '';
end
else
begin
case Day of
5:
if CnMonthOfDate(Date) = '五月' then
Result := '端午节'
else
Result := '';
7:
if CnMonthOfDate(Date) = '七月' then
Result := '七夕节'
else
Result := '';
15:
if CnMonthOfDate(Date) = '八月' then
Result := '中秋节'
else
Result := '';
9:
if CnMonthOfDate(Date) = '九月' then
Result := '重阳节'
else
Result := '';
8:
if CnMonthOfDate(Date) = '腊月' then
Result := '腊八节'
else
Result := '';
else
if (CnMonthOfDate(Date + 1) = '正月') then
Result := '除夕'
else
Result := '';
end; {case}
end;
end;
function CnanimalOfYear(Date: TDate): string; //返回十二生肖
begin
case (StrToInt(Copy(DateToStr(Date), 1, 4)) - StrToInt(BaseAnimalDate))
mod 12 of
0:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '子鼠'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '亥猪'
else
Result := '子鼠';
end;
1, -11:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '丑牛'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '子鼠'
else
Result := '丑牛';
end;
2, -10:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '寅虎'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '丑牛'
else
Result := '寅虎';
end;
3, -9:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '卯兔'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '寅虎'
else
Result := '卯兔';
end;
4, -8:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '辰龙'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '卯兔'
else
Result := '辰龙';
end;
5, -7:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '巳蛇'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '辰龙'
else
Result := '巳蛇';
end;
6, -6:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '午马'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '巳蛇'
else
Result := '午马';
end;
7, -5:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '未羊'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '午马'
else
Result := '未羊';
end;
8, -4:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '申猴'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '未羊'
else
Result := '申猴';
end;
9, -3:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '酉鸡'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '申猴'
else
Result := '酉鸡';
end;
10, -2:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '戌狗'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '酉鸡'
else
Result := '戌狗';
end;
11, -1:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '亥猪'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '戌狗'
else
Result := '亥猪';
end;
end; {case}
end;
function CnSkyStemOfYear(Date: TDate): string; //返回十大天干
begin
case (StrToInt(Copy(DateToStr(Date), 1, 4)) - StrToInt(BaseSkyStemDate))
mod 10 of
0:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '甲'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '癸'
else
Result := '甲';
end;
1, -9:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '乙'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '甲'
else
Result := '乙';
end;
2, -8:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '丙'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '乙'
else
Result := '丙';
end;
3, -7:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '丁'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '丙'
else
Result := '丁';
end;
4, -6:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '戊'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '丁'
else
Result := '戊';
end;
5, -5:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '巳'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '戊'
else
Result := '巳';
end;
6, -4:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '庚'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '巳'
else
Result := '庚';
end;
7, -3:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '辛'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '庚'
else
Result := '辛';
end;
8, -2:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '壬'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '辛'
else
Result := '壬';
end;
9, -1:
if (StrToInt(Copy(DateToStr(Date), 6, 2)) < 4) and ((Pos('腊',
CnMonthOfDate(Date)) = 0) and (Pos('冬', CnMonthOfDate(Date)) = 0)) then
Result := '癸'
else
begin
if StrToInt(Copy(DateToStr(Date), 6, 2)) < 4 then
Result := '壬'
else
Result := '癸';
end;
end;
end;
end.
J
jswqg
Unregistered / Unconfirmed
GUEST, unregistred user!
gz
I
IUnknow
Unregistered / Unconfirmed
GUEST, unregistred user!
http://www.csdn.net/expert/topic/408/408325.xml
Z
zhoudang
Unregistered / Unconfirmed
GUEST, unregistred user!
多人接受答案了。