日曆函式單元 (轉)[@more@]

//原始版權宣告：

/***************************************************************************
致看到這些的兄弟:
你好!
這本來是我為一個商業PDA產品開發的日曆,最近移植於PC機上, 所以演算法
和資料部分是用純C++寫的,不涉及MFC,所有的程式碼都是以短節省空間為主要目
的.
很高興你對這些程式碼有興趣,你可以隨意複製和使用些程式碼,唯一有一點小小的
願望:在你使用和複製給別人時,別忘註明這些程式碼作者:-)。程式程式碼也就罷了,後
面的資料可是我辛辛苦苦從萬年曆上找出來輸進去的。
如果你有什麼好的意見不妨給我。

或

2000年3月
****************************************************************************/

//Translated and modified by Icebird from C++ to 5 on 2001.1

unit Calendar;

interface

uses SysUtils, ;

const
START_YEAR = 1901;
END_YEAR = 2050;

// ==> function IsLeapYear(Year: ): Boolean;

//計算iYear,iMonth,iDay對應是星期幾 1年1月1日 --- 65535年12月31日
function WeekDay(iYear, iMonth, iDay: Word): Integer;
// ==> function DayOfWeek(Date: TDateTime): Integer;

//計算指定日期的週數，周0為新年開始後第一個星期天開始的周
function WeekNum(const TDT: TDateTime): Word; overload;
function WeekNum(const iYear, iMonth, iDay: Word): Word; overload;

//返回iYear年iMonth月的天數 1年1月 --- 65535年12月
function MonthDays(iYear, iMonth: Word): Word;

//返回陰曆iLunarYer年陰曆iLunarMonth月的天數，如果iLunarMonth為閏月，
//高字為第二個iLunarMonth月的天數，否則高字為0
// 1901年1月---2050年12月
function LunarMonthDays(iLunarYear, iLunarMonth: Word): Longword;

//返回陰曆iLunarYear年的總天數
// 1901年1月---2050年12月
function LunarYearDays(iLunarYear: Word): Word;

//返回陰曆iLunarYear年的閏月月份，如沒有返回0
// 1901年1月---2050年12月
function GetLeapMonth(iLunarYear: Word): Word;

//把iYear年格式化成天干記年法表示的字串
procedure FormatLunarYear(iYear: Word; var pBuffer: string); overload;
function FormatLunarYear(iYear: Word): string; overload;

//把iMonth格式化成中文字串
procedure FormatMonth(iMonth: Word; var pBuffer: string; bLunar: Boolean = True); overload;
function FormatMonth(iMonth: Word; bLunar: Boolean = True): string; overload;

//把iDay格式化成中文字串
procedure FormatLunarDay(iDay: Word; var pBuffer: string); overload;
function FormatLunarDay(iDay: Word): string; overload;

//計算公曆兩個日期間相差的天數 1年1月1日 --- 65535年12月31日
function CalcDateDiff(iEndYear, iEndMonth, iEndDay: Word; iStartYear: Word = START_YEAR; iStartMonth: Word = 1; iStartDay: Word = 1): Longword; overload;
function CalcDateDiff(EndDate, StartDate: TDateTime): Longword; overload;

//計算公曆iYear年iMonth月iDay日對應的陰曆日期,返回對應的陰曆節氣 0-24
//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;

//private function--------------------------------------

//計算從1901年1月1日過iSpanDays天后的陰曆日期
procedure l_CalcLunarDate(var iYear, iMonth, iDay: Word; iSpanDays: Longword);

//計算公曆iYear年iMonth月iDay日對應的節氣 0-24，0表不是節氣
function l_GetLunarHolDay(iYear, iMonth, iDay: Word): Word;

//計算指定日期所對應的星座
function GetConstellation(const DateTime: TDateTime): Integer;
function GetConstellationName(const Constellation: Integer): string; overload;
function GetConstellationName(const DateTime: TDateTime): string; overload;

implementation

var
//陣列gLunarDay存入陰曆1901年到2100年每年中的月天數資訊，
//陰曆每月只能是29或30天，一年用12（或13）個二進位制位表示，對應位為1表30天，否則為29天
gLunarMonthDay: array[0..149] of Word = (
//測試資料只有1901.1.1 --2050.12.31
$4AE0, $A570, $5268, $D260, $D950, $6AA8, $56A0, $9AD0, $4AE8, $4AE0, //1910
$A4D8, $A4D0, $D250, $D548, $B550, $56A0, $96D0, $95B0, $49B8, $49B0, //1920
$A4B0, $B258, $6A50, $6D40, $ADA8, $2B60, $9570, $4978, $4970, $64B0, //1930
$D4A0, $EA50, $6D48, $5AD0, $2B60, $9370, $92E0, $C968, $C950, $D4A0, //1940
$DA50, $B550, $56A0, $AAD8, $25D0, $92D0, $C958, $A950, $B4A8, $6CA0, //1950
$B550, $55A8, $4DA0, $A5B0, $52B8, $52B0, $A950, $E950, $6AA0, $AD50, //1960
$AB50, $4B60, $A570, $A570, $5260, $E930, $D950, $5AA8, $56A0, $96D0, //1970
$4AE8, $4AD0, $A4D0, $D268, $D250, $D528, $B540, $B6A0, $96D0, $95B0, //1980
$49B0, $A4B8, $A4B0, $B258, $6A50, $6D40, $ADA0, $AB60, $9370, $4978, //1990
$4970, $64B0, $6A50, $EA50, $6B28, $5AC0, $AB60, $9368, $92E0, $C960, //2000
$D4A8, $D4A0, $DA50, $5AA8, $56A0, $AAD8, $25D0, $92D0, $C958, $A950, //2010
$B4A0, $B550, $B550, $55A8, $4BA0, $A5B0, $52B8, $52B0, $A930, $74A8, //2020
$6AA0, $AD50, $4DA8, $4B60, $9570, $A4E0, $D260, $E930, $D530, $5AA0, //2030
$6B50, $96D0, $4AE8, $4AD0, $A4D0, $D258, $D250, $D520, $DAA0, $B5A0, //2040
$56D0, $4AD8, $49B0, $A4B8, $A4B0, $AA50, $B528, $6D20, $ADA0, $55B0); //2050

//陣列gLanarMonth存放陰曆1901年到2050年閏月的月份，如沒有則為0，每位元組存兩年
gLunarMonth: array[0..74] of Byte = (
$00, $50, $04, $00, $20, //1910
$60, $05, $00, $20, $70, //1920
$05, $00, $40, $02, $06, //1930
$00, $50, $03, $07, $00, //1940
$60, $04, $00, $20, $70, //1950
$05, $00, $30, $80, $06, //1960
$00, $40, $03, $07, $00, //1970
$50, $04, $08, $00, $60, //1980
$04, $0A, $00, $60, $05, //1990
$00, $30, $80, $05, $00, //2000
$40, $02, $07, $00, $50, //2010
$04, $09, $00, $60, $04, //2020
$00, $20, $60, $05, $00, //2030
$30, $B0, $06, $00, $50, //2040
$02, $07, $00, $50, $03); //2050

//陣列gLanarHoliDay存放每年的二十四節氣對應的陽曆日期
//每年的二十四節氣對應的陽曆日期幾乎固定，平均分佈於十二個月中
// 1月 2月 3月 4月 5月 6月
//小寒大寒立春雨水驚蟄春分清明穀雨立夏小滿芒種夏至
// 7月 8月 9月 10月 11月 12月
//小暑大暑立秋處暑白露秋分寒露霜降立冬小雪大雪冬至
{*********************************************************************************
節氣無任何確定規律,所以只好存表,要節省空間,所以....
**********************************************************************************}
//資料格式說明:
//如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
//上面第一行資料為每月節氣對應日期,15減去每月第一個節氣,每月第二個節氣減去15得第二行
// 這樣每月兩個節氣對應資料都小於16,每月用一個位元組存放,高位存放第一個節氣資料,低位存放
//第二個節氣的資料,可得下表
gLunarHolDay: array[0..1799] of Byte = (
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1901
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, //1902
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, //1903
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, //1904
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1905
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, //1906
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, //1907
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1908
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1909
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, //1910
$96, $A5, $87, $96, $87, $87, $79, $69, $69, $69, $78, $78, //1911
$86, $A5, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1912
$95, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1913
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, //1914
$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, //1915
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1916
$95, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $87, //1917
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, //1918
$96, $A5, $97, $96, $97, $87, $79, $79, $69, $69, $78, $78, //1919
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1920
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, //1921
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $77, //1922
$96, $A4, $96, $96, $97, $87, $79, $79, $69, $69, $78, $78, //1923
$96, $A5, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1924
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $87, //1925
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1926
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, //1927
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1928
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1929
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1930
$96, $A4, $96, $96, $97, $87, $79, $79, $79, $69, $78, $78, //1931
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1932
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1933
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1934
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, //1935
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1936
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1937
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1938
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, //1939
$96, $A5, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1940
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1941
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1942
$96, $A4, $96, $96, $97, $97, $79, $79, $79, $69, $78, $78, //1943
$96, $A5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, //1944
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1945
$95, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, //1946
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, //1947
$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //1948
$A5, $B4, $96, $A5, $96, $97, $88, $79, $78, $79, $77, $87, //1949
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, //1950
$96, $B4, $96, $A6, $97, $97, $79, $79, $79, $69, $78, $78, //1951
$96, $A5, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //1952
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1953
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $68, $78, $87, //1954
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1955
$96, $A5, $A5, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //1956
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1957
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1958
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1959
$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, //1960
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1961
$96, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1962
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1963
$96, $A4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, //1964
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1965
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1966
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1967
$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //1968
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1969
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1970
$96, $B4, $96, $A6, $97, $97, $78, $79, $79, $69, $78, $77, //1971
$96, $A4, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //1972
$A5, $B5, $96, $A5, $A6, $96, $88, $78, $78, $78, $87, $87, //1973
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1974
$96, $B4, $96, $A6, $97, $97, $78, $79, $78, $69, $78, $77, //1975
$96, $A4, $A5, $B5, $A6, $A6, $88, $89, $88, $78, $87, $87, //1976
$A5, $B4, $96, $A5, $96, $96, $88, $88, $78, $78, $87, $87, //1977
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, //1978
$96, $B4, $96, $A6, $96, $97, $78, $79, $78, $69, $78, $77, //1979
$96, $A4, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, //1980
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $77, $87, //1981
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1982
$95, $B4, $96, $A5, $96, $97, $78, $79, $78, $69, $78, $77, //1983
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, //1984
$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //1985
$A5, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //1986
$95, $B4, $96, $A5, $96, $97, $88, $79, $78, $69, $78, $87, //1987
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //1988
$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, //1989
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, //1990
$95, $B4, $96, $A5, $86, $97, $88, $78, $78, $69, $78, $87, //1991
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //1992
$A5, $B3, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, //1993
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1994
$95, $B4, $96, $A5, $96, $97, $88, $76, $78, $69, $78, $87, //1995
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //1996
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //1997
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //1998
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //1999
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //2000
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2001
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //2002
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //2004
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2005
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2006
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $69, $78, $87, //2007
$96, $B4, $A5, $B5, $A6, $A6, $87, $88, $87, $78, $87, $86, //2008
$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2009
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2010
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $78, $87, //2011
$96, $B4, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, //2012
$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, //2013
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2014
$95, $B4, $96, $A5, $96, $97, $88, $78, $78, $79, $77, $87, //2015
$95, $B4, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, //2016
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, //2017
$A5, $B4, $A6, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2018
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, //2019
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $86, //2020
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //2021
$A5, $B4, $A5, $A5, $A6, $96, $88, $88, $88, $78, $87, $87, //2022
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $79, $77, $87, //2023
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, //2024
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //2025
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2026
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //2027
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, //2028
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //2029
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2030
$A5, $B4, $96, $A5, $96, $96, $88, $78, $78, $78, $87, $87, //2031
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, //2032
$A5, $C3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $86, //2033
$A5, $B3, $A5, $A5, $A6, $A6, $88, $78, $88, $78, $87, $87, //2034
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2035
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, //2036
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $86, //2037
$A5, $B3, $A5, $A5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2038
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2039
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $78, $87, $96, //2040
$A5, $C3, $A5, $B5, $A5, $A6, $87, $88, $87, $78, $87, $86, //2041
$A5, $B3, $A5, $B5, $A6, $A6, $88, $88, $88, $78, $87, $87, //2042
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2043
$95, $B4, $A5, $B4, $A5, $A6, $97, $87, $87, $88, $87, $96, //2044
$A5, $C3, $A5, $B4, $A5, $A6, $87, $88, $87, $78, $87, $86, //2045
$A5, $B3, $A5, $B5, $A6, $A6, $87, $88, $88, $78, $87, $87, //2046
$A5, $B4, $96, $A5, $A6, $96, $88, $88, $78, $78, $87, $87, //2047
$95, $B4, $A5, $B4, $A5, $A5, $97, $87, $87, $88, $86, $96, //2048
$A4, $C3, $A5, $A5, $A5, $A6, $97, $87, $87, $78, $87, $86, //2049
$A5, $C3, $A5, $B5, $A6, $A6, $87, $88, $78, $78, $87, $87); //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: Word; iStartDay: Word): Longword;
begin
Result := Trunc(EncodeDate(iEndYear, iEndMonth, iEndDay) - EncodeDate(iStartYear, iStartMonth, iStartDay));
end;

function CalcDateDiff(EndDate, StartDate: TDateTime): Longword;
begin
Result := Trunc(EndDate - StartDate);
end;

function GetLunarDate(iYear, iMonth, iDay: Word; var iLunarYear, iLunarMonth, iLunarDay: Word): Word;
begin
l_CalcLunarDate(iLunarYear, iLunarMonth, iLunarDay, CalcDateDiff(iYear, iMonth, iDay));
Result := l_GetLunarHolDay(iYear, iMonth, iDay);
end;

procedure GetLunarDate(InDate: TDateTime; var iLunarYear, iLunarMonth, iLunarDay: Word);
begin
l_CalcLunarDate(iLunarYear, iLunarMonth, iLunarDay, CalcDateDiff(InDate, EncodeDate(START_YEAR, 1, 1)));
end;

procedure l_CalcLunarDate(var iYear, iMonth, iDay: Word; iSpanDays: Longword);
var
tmp: Longword;
begin
//陽曆1901年2月19日為陰曆1901年正月初一
//陽曆1901年1月1日到2月19日共有49天
if iSpanDays < 49 then
begin
iYear := START_YEAR - 1;
if iSpanDays < 19 then
begin
iMonth := 11;
iDay := 11 + Word(iSpanDays);
end
else
begin
iMonth := 12;
iDay := Word(iSpanDays) - 18;
end;
Exit;
end;
//下面從陰曆1901年正月初一算起
iSpanDays := iSpanDays - 49;
iYear := START_YEAR;
iMonth := 1;
iDay := 1;
//計算年
tmp := LunarYearDays(iYear);
while iSpanDays >= tmp do
begin
iSpanDays := iSpanDays - tmp;
Inc(iYear);
tmp := LunarYearDays(iYear);
end;
//計算月
tmp := LoWord(LunarMonthDays(iYear, iMonth));
while iSpanDays >= tmp do
begin
iSpanDays := iSpanDays - tmp;
if iMonth = GetLeapMonth(iYear) then
begin
tmp := HiWord(LunarMonthDays(iYear, iMonth));
if iSpanDays < tmp then
Break;
iSpanDays := iSpanDays - tmp;
end;
Inc(iMonth);
tmp := LoWord(LunarMonthDays(iYear, iMonth));
end;
//計算日
iDay := iDay + Word(iSpanDays);
end;

function l_GetLunarHolDay(iYear, iMonth, iDay: Word): Word;
var
Flag: Byte;
Day: Word;
begin
Flag := gLunarHolDay[(iYear - START_YEAR) * 12 + iMonth - 1];
if iDay < 15 then
Day := 15 - ((Flag shr 4) and $0F)
else
Day := (Flag and $0F) + 15;
if iDay = Day then
if iDay > 15 then
Result := (iMonth - 1) * 2 + 2
else
Result := (iMonth - 1) * 2 + 1
else
Result := 0;
end;

function GetLunarHolDay(InDate: TDateTime): string;
var
i, iYear, iMonth, iDay: Word;
begin
DecodeDate(InDate, iYear, iMonth, iDay);
i := l_GetLunarHolDay(iYear, iMonth, iDay);
case i of
1: Result := '小寒';
2: Result := '大寒';
3: Result := '立春';
4: Result := '雨水';
5: Result := '驚蟄';
6: Result := '春分';
7: Result := '清明';
8: Result := '穀雨';
9: Result := '立夏';
10: Result := '小滿';
11: Result := '芒種';
12: Result := '夏至';
13: Result := '小暑';
14: Result := '大暑';
15: Result := '立秋';
16: Result := '處暑';
17: Result := '白露';
18: Result := '秋分';
19: Result := '寒露';
20: Result := '霜降';
21: Result := '立冬';
22: Result := '小雪';
23: Result := '大雪';
24: Result := '冬至';
else
Result := '';
end;
end;

function GetLunarHolDay(iYear, iMonth, iDay: Word): string;
begin
Result := GetLunarHolDay(EncodeDate(iYear, iMonth, iDay));
end;

function GetConstellation(const DateTime: TDateTime): Integer;
var
Y, M, D: Word;
begin
DecodeDate(DateTime, Y, M, D);
Y := M * 100 + D;
if (Y >= 321) and (Y <= 419) then
Result := 0
else
if (Y >= 420) and (Y <= 520) then
Result := 1
else
if (Y >= 521) and (Y <= 620) then
Result := 2
else
if (Y >= 621) and (Y <= 722) then
Result := 3
else
if (Y >= 723) and (Y <= 822) then
Result := 4
else
if (Y >= 823) and (Y <= 922) then
Result := 5
else
if (Y >= 923) and (Y <= 1022) then
Result := 6
else
if (Y >= 1023) and (Y <= 1121) then
Result := 7
else
if (Y >= 1122) and (Y <= 1221) then
Result := 8
else
if (Y >= 1222) or (Y <= 119) then
Result := 9
else
if (Y >= 120) and (Y <= 218) then
Result := 10
else
if (Y >= 219) and (Y <= 320) then
Result := 11
else
Result := -1;
end;

function GetConstellationName(const Constellation: Integer): string;
begin
case Constellation of
0: Result := '白羊座';
1: Result := '金牛座';
2: Result := '雙子座';
3: Result := '巨蟹座';
4: Result := '獅子座';
5: Result := '處女座';
6: Result := '天秤座';
7: Result := '天蠍座';
8: Result := '射手座';
9: Result := '摩羯座';
10: Result := '水瓶座';
11: Result := '雙魚座';
else
Result := '';
end;
end;

function GetConstellationName(const DateTime: TDateTime): string;
begin
Result := GetConstellationName(GetConstellation(DateTime));
end;

end.

日曆函式單元 (轉)

相關文章