飘云阁一個超棒的農曆控件 for Delphi

黑夜彩虹 发表于 2006-6-4 22:47:06

一個超棒的農曆控件 for Delphi

一個超棒的農曆控件 for Delphi
ChnCalendar.pas
unit ChnCalendar;

interface

uses
Windows, DateUtils, Messages, DateWin, Forms, SysUtils, DateCn, StdCtrls, Classes, Controls, CommCtrl, ComCtrls, Graphics;

type
tagRGBTRIPLE = packed record
rgbtBlue: Byte;
rgbtGreen: Byte;
rgbtRed: Byte;
end;
TRGBTriple = tagRGBTRIPLE;
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array of TRGBTriple;
TChnCalendar = class(TCustomControl)
private
{ Private declarations }
// isChangeBmp: Boolean;
CnDate: string;
ButtonRect: TRect;
YearEdit,
   MonthEdit,
   DayEdit: TEdit;
MouseStyle: integer;
FLastChange: TSystemTime;
FDateTime: TDateTime;
FFrameColor: TColor;
FCnDateColor: TColor;
FButtonColor: TColor;
FBackPicture: TbitMap;
FAlphaBlend: Byte;
procedure DrawButton(iStyle: integer);
procedure SetDateTime(const Value: TDateTime);
procedure WMSize(var Msg: TWMSize); message wm_Size;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure SetFrameColor(const Value: TColor);
procedure setCnDateColor(const Value: TColor);
procedure setButtonColor(const Value: TColor);
procedure SetBackPicture(const Value: TbitMap);
// procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
// procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
protected
{ Protected declarations }
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property DateTime: TDateTime read FDateTime write SetDateTime;
property FrameColor: TColor read FFrameColor write SetFrameColor;
property CnDateColor: TColor read FCnDateColor write setCnDateColor;
property ButtonColor: TColor read FButtonColor write setButtonColor;
property BackPicture: TbitMap read FBackPicture write SetBackPicture;
property AlphaBlend: Byte read FAlphaBlend write FAlphaBlend;
property Color;
property Align;
property Anchors;
property Enabled;
property Font;
property ParentBiDiMode;
property ParentBackground;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDblClick;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnResize;
end;

procedure Register;

implementation

uses Grids;

procedure Register;
begin
RegisterComponents('Standard', );
end;

{ TChnCalendar }

constructor TChnCalendar.Create(AOwner: TComponent);
begin
//CheckCommonControl(ICC_USEREX_CLASSES);
inherited Create(AOwner);
//DateTimeToSystemTime(DateTime, FLastChange);
//FShowCheckbox := False;
//FChecked := True;
SetBounds(0, 0, 186, 15);
ControlStyle := ControlStyle + ;
FBackPicture := TBitMap.Create;
Color := clWindow;
FCnDateColor := clGreen;
FButtonColor := clPurple;
FAlphaBlend := 50;
ParentColor := False;
TabStop := True;
YearEdit := TEdit.Create(Self);
with YearEdit do
begin
BorderStyle := bsNone;
Parent := Self;
SetBounds(0, 0, 31, 13);
Left := 3;
Top := 1;
Text := FormatDateTime('YYYY', Now);
end;

MonthEdit := TEdit.Create(Self);
with MonthEdit do
begin
BorderStyle := bsNone;
Parent := Self;
SetBounds(0, 0, 15, 13);
Left := 41;
Top := 1;
Text := FormatDateTime('M', Now);
end;

DayEdit := TEdit.Create(Self);
with DayEdit do
begin
BorderStyle := bsNone;
Parent := Self;
SetBounds(0, 0, 15, 13);
Left := 65;
Top := 1;
Text := FormatDateTime('D', Now);
end;

FRM_Date := TFRM_Date.Create(Application);
DateTime := Now;
//CnDate := CnanimalOfYear(DateTime) + CnMonthOfDate(DateTime) + CnDayOfDate(DateTime);

end;

destructor TChnCalendar.Destroy;
begin
FBackPicture.Free;
inherited;
end;

procedure TChnCalendar.DrawButton(iStyle: integer);
procedure Trigon(Canvas: TCanvas; xy1, xy2, xy3: TPoint);
var
xy: array of TPoint;
begin
xy := xy1;
xy := xy2;
xy := xy3;
xy := xy1;
Canvas.Polygon(xy);
end;
var
TrigonLeft: integer;
begin
Canvas.Brush.Style := bsSolid;
case iStyle of
0:
   begin
   Canvas.Pen.Color := FrameColor;
   Canvas.Brush.Color := FButtonColor; // clPurple;
   end;
1, 2:
   begin
   Canvas.Pen.Color := clBlack;
   Canvas.Brush.Color := $00E47AC8;
   end;
end;

Canvas.Rectangle(RECT(Width - 15, 1, Width - 1, Height - 1));

//画三角形
case iStyle of
0, 1:
   begin
   Canvas.Brush.Color := clWhite;
   Canvas.Pen.Color := clWhite;
   end;
2:
   begin
   Canvas.Brush.Color := $00E4E4E4;
   Canvas.Pen.Color := $00E4E4E4;
   end;
end;
TrigonLeft := Width - 15;
Trigon(Canvas, Point(TrigonLeft + 3, 5), Point(TrigonLeft + 9, 5), Point(TrigonLeft + 6, 8));

end;

procedure TChnCalendar.Paint;
var
TextTop: integer;
begin
inherited;
YearEdit.Color := color;
MonthEdit.Color := color;
DayEdit.Color := Color;
ButtonRect := RECT(Width - 15, 1, Width - 1, Height - 1);
Canvas.Pen.Color := FrameColor;
Canvas.Brush.Color := Color;
Canvas.FillRect(ClientRect);
Canvas.Rectangle(ClientRect);
canvas.Font.Color := Font.Color;
TextTop := (Height - canvas.TextHeight('A')) div 2;
Canvas.TextOut(33, TextTop, '-');
Canvas.TextOut(60, TextTop, '-');
canvas.Font.Color := FCnDateColor;
Canvas.TextOut(84, TextTop, CnDate);
canvas.Font.Color := Font.Color;

DrawButton(0);
end;

procedure BmpAlphaBlend(var dBmp: TBitMap; sBmp: TBitmap; Pos: TPoint; Alpha: integer; TranColor: TColor = -1);
function IntToByte(i: Integer): Byte;
begin
if i > 255 then
   Result := 255
else if i < 0 then
   Result := 0
else
   Result := i;
end;
function GetSLColor(pRGB: TRGBTriple): TColor;
begin
Result := RGB(pRGB.rgbtRed, pRGB.rgbtGreen, pRGB.rgbtBlue);
end;
var
p0, p1: PRGBTripleArray;
r, g, b, p, x, y: Integer;
begin
sBmp.PixelFormat := pf24bit;
dBmp.PixelFormat := pf24bit;
if TranColor = -1 then
TranColor := sBmp.Canvas.Pixels;
for y := 0 to sBmp.Height - 1 do
if (y + Pos.y >= 0) and (y + Pos.Y < dBmp.Height) then
begin
   p0 := dBmp.ScanLine;
   p1 := sBmp.ScanLine;
   for x := 0 to sBmp.Width - 1 do
   if (x + pos.X >= 0) and (x + Pos.X < dBmp.Width) then
      if GetSLCOlor(p1) <> TranColor then
      begin
         p0.rgbtRed := IntToByte((p0.rgbtRed * (100 - Alpha) +
         p1.rgbtRed * Alpha) div 100);

         p0.rgbtGreen := IntToByte((p0.rgbtGreen * (100 - Alpha) +
         p1.rgbtGreen * Alpha) div 100);

         p0.rgbtBlue := IntToByte((p0.rgbtBlue * (100 - Alpha) +
         p1.rgbtBlue * Alpha) div 100);
      end;
end;

end;

procedure TChnCalendar.SetBackPicture(const Value: TbitMap);
begin
FBackPicture.Assign(Value);

end;

procedure TChnCalendar.setButtonColor(const Value: TColor);
begin
if FButtonColor <> Value then
begin
FButtonColor := Value;
Invalidate;
end;
end;

procedure TChnCalendar.setCnDateColor(const Value: TColor);
begin
if FCnDateColor <> Value then
begin
FCnDateColor := Value;
Invalidate;
end;
end;

procedure TChnCalendar.SetDateTime(const Value: TDateTime);
begin
if Value <> FDateTime then
begin
FDateTime := Value;
YearEdit.Text := FormatDateTime('YYYY', FDateTime);
MonthEdit.Text := FormatDateTime('m', FDateTime);
DayEdit.Text := FormatDateTime('d', FDateTime);
CnDate := CnanimalOfYear(DateTime) + CnMonthOfDate(DateTime) + CnDayOfDate(DateTime);
Invalidate;
end;
end;

procedure TChnCalendar.SetFrameColor(const Value: TColor);
begin
FFrameColor := Value;
Invalidate;
end;

function FormExists(FORM_NAME: string): BOOLEAN;
begin
if Application.FindComponent(FORM_NAME) = nil then
RESULT := FALSE
else
RESULT := TRUE;
end;

function DayOfMonth(Year, Month: Integer): integer; overload;
begin
try
Result := MonthDays;
except
Result := 0;
end;
end;

function DayOfMonth(Dates: TDateTime): integer; overload;
var
Year, Month, Day, Hour: Word;

begin
DecodeDate(Dates, Year, Month, day);
Result := MonthDays;
end;

function DaysOfMonth(Dates: TDateTime): Integer;
begin
Result := DayOfMonth(YearOf(Dates), MonthOf(Dates));
end;

function SetDateTime(NYear, NMonth, NDay: Word): TDate;
var
MyDay: Word;
begin
MyDay := DayOfMonth(NYear, NMonth);
if MyDay < NDay then
NDay := MyDay;
Result := EncodeDate(NYear, NMonth, NDay);

end;

procedure AdjustDropDownForm(AControl: TControl; HostControl: TControl);
var
WorkArea: TRect;
HostP, PDelpta: TPoint;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
HostP := HostControl.ClientToScreen(Point(0, 0));
PDelpta := AControl.ClientToScreen(Point(0, 0));

AControl.Left := HostP.x;
AControl.Top := HostP.y + HostControl.Height + 1;

if (AControl.Width > WorkArea.Right - WorkArea.Left) then
AControl.Width := WorkArea.Right - WorkArea.Left;

if (AControl.Left + AControl.Width > WorkArea.Right) then
AControl.Left := WorkArea.Right - AControl.Width;
if (AControl.Left < WorkArea.Left) then
AControl.Left := WorkArea.Left;

if (AControl.Top + AControl.Height > WorkArea.Bottom) then
begin
if (HostP.y - WorkArea.Top > WorkArea.Bottom - HostP.y - HostControl.Height) then
   AControl.Top := HostP.y - AControl.Height;
end;

if (AControl.Top < WorkArea.Top) then
begin
AControl.Height := AControl.Height - (WorkArea.Top - AControl.Top);
AControl.Top := WorkArea.Top;
end;

if (AControl.Top + AControl.Height > WorkArea.Bottom) then
begin
AControl.Height := WorkArea.Bottom - AControl.Top;
end;

end;

procedure TChnCalendar.WMLButtonDown(var Message: TWMLButtonDown);
var
xy: TPoint;
P: TPoint;
bmp: TbitMap;
begin
xy := Point(Message.Pos.x, Message.Pos.y);
if PtInRect(ButtonRect, xy) then
begin
// FRM_Date.ShowDateWin(YearEdit, MonthEdit, DayEdit, Self);
FRM_Date.YearEdit := YearEdit;
FRM_Date.MonthEdit := MonthEdit;
FRM_Date.DayEdit := DayEdit;
MHostControl := Self;
//if isChangeBmp then
with FRM_Date do
begin
   Image1.Picture.Bitmap.Assign(FBackPicture);
   Label16.Visible := FBackPicture.Width =0;
   Label20.Visible := FBackPicture.Width =0;
   if Image1.Picture.Graphic <> nil then
   begin
   bmp := TbitMap.Create;
   bmp.Width := Image1.Width;
   bmp.Height := Image1.Height;
   bmp.Canvas.Brush.Color := Color;
   bmp.Canvas.FillRect(RECT(0, 0, bmp.Width,
      bmp.Height));

   P := Point((bmp.Width - FBackPicture.Width) div 2,
      (bmp.Height - FBackPicture.Height) div 2);
   BmpAlphaBlend(bmp, FBackPicture, P, FAlphaBlend);
   Image1.Canvas.Draw(0, 0, bmp);
   bmp.free;

   end;
end;
// isChangeBmp := False;

with FRM_Date do
begin
   if Image1.Picture.Graphic = nil then
   StaticText1.Caption := 'aaaa';

   YearEdit.Text := IntToStr(StrTOIntDef(YearEdit.Text, YearOf(Date)));
   MonthEdit.Text := IntToStr(StrTOIntDef(MonthEdit.Text, MonthOf(Date)));
   DayEdit.Text := IntToStr(StrTOIntDef(DayEdit.Text, DayOfMonth(Date)));

   if (StrToInt(YearEdit.Text) > 2050) or (StrToInt(YearEdit.Text) < 1901) then
   YearEdit.Text := IntToStr(YearOf(Date));

   if (StrToInt(MonthEdit.Text) > 12) or (StrToInt(MonthEdit.Text) < 1) then
   MonthEdit.Text := IntToStr(MonthOf(Date));

   if StrToInt(DayEdit.Text) > DayOfMonth(StrToInt(YearEdit.Text), StrToInt(MonthEdit.Text)) then
   DayEdit.Text := IntToStr(DayOfMonth(StrToInt(YearEdit.Text), StrToInt(MonthEdit.Text)));

   NDate := EncodeDate(StrToInt(YearEdit.text), StrToInt(MonthEdit.text), StrToInt(DayEdit.text));
end;
AdjustDropDownForm(FRM_Date, Self);
FRM_Date.Show;
// ShowWindow(MonthWin.Handle, SW_SHOWNORMAL);
end;
{ if MouseStyle <> 2 then
begin
   MouseStyle := 2;
   DrawButton(2);
end;
}
end;
{
procedure TChnCalendar.WMLButtonUp(var Message: TWMLButtonUp);
var
xy: TPoint;
begin
xy := Point(Message.Pos.x, Message.Pos.y);
if PtInRect(ButtonRect, xy) then
begin
MouseStyle := 0;
DrawButton(0);
end;

end;

procedure TChnCalendar.WMMouseMove(var Message: TWMMouseMove);
var
xy: TPoint;
begin
xy := Point(Message.Pos.x, Message.Pos.y);
if PtInRect(ButtonRect, xy) then
if MouseStyle <> 1 then
begin
   MouseStyle := 1;
   DrawButton(1);
end;

end;
}

procedure TChnCalendar.WMSize(var Msg: TWMSize);
begin
YearEdit.Top := (Height - YearEdit.Height) div 2;
MonthEdit.Top := YearEdit.Top;
DayEdit.Top := YearEdit.Top;
end;

end.

[ 本帖最后由黑夜彩虹于 2006-6-4 22:57 编辑 ]

黑夜彩虹 发表于 2006-6-4 22:48:08

DateCn.pas

DateCn.pas
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: 76543210 76543210
//农历月份:16 15 14 13 12 11 10 9 87654321
//农历月份指的是从该年1月1日的农历月份算起的顺序号
//农历月份对应的bit为1则该月为30日，否则为29日
//第四字节为闰月月份
//BaseDate='2000/02/04';//2000立春
BaseAnimalDate = '1972'; //1972年支为子(是鼠年)
BaseSkyStemDate = '1974'; //1974年干为甲
START_YEAR = 1901;
END_YEAR = 2050;

gLunarHolDay: Array 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, //2003
$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

CnData: Array 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; Days: Integer): String; OverLoad;
Function CnMonthOfDate(Date: TDate): String; OverLoad; //指定日期的农历月

Function CnMonth(Date: TDate): Integer; //指定日期的农历月
Function CnDay(Date: TDate): Integer; //指定日期的农历日包括节日
Function CnDayOfDate(Date: TDate): String; overload; //指定日期的农历日包括节日
Function CnDayOfDate(Year,Month,Day: integer): String; overload; //指定日期的农历日包括节日

Function CnDayOfDate(Date: TDate; Days: integer; ShowDate: Boolean = false): String; overload; //指定日期的农历日包括节日

Function CnDateOfDateStr(Date: TDate): String; //指定日期的农历日期
Function CnDayOfDatePH(Date: TDate): String; //指定日期的农历月
Function CnDateOfDateStrPH(Date: TDate): String; //指定日期的农历日期包括节日

Function CnDayOfDateJr(Date: TDate): String; overload; //只有节日
Function CnDayOfDateJr(Date: TDate; Days: Integer): String; overload; //只有节日

Function CnanimalOfYear(Date: TDate): String; //返回十二生肖(地支)
Function CnSkyStemOfYear(Date: TDate): String; //返回十大天干
Function CnSolarTerm(Date: TDate): String; //返回十大天干

Function GetLunarHolDay(InDate: TDateTime): String; overload;
Function GetLunarHolDay(InDate: TDateTime; Days: Integer): String; overload;

Function l_GetLunarHolDay(iYear, iMonth, iDay: Word): Word;
Function GetAnimal(Date: TDate): integer; //返回十二生肖

Function GetCnDateToDate(dDate: TDateTime): TDateTime; overload;
Function GetCnDateToDate(cYear, cMonth, cDay: word): TDateTime; overload;

Function OtherHoliday(Month, Day: integer): String;
Function Holiday(Date: TDateTime; Day: integer): String;
Function GetDays(ADate: TDate): Extended;

Function Constellation(Date: TDateTime; Day: integer): String; overload;
Function Constellation(ADate: TDate): String; overload;
//procedure l_CalcLunarDate(var iYear,iMonth,iDay:Word;iSpanDays:Longword);
//function CalcDateDiff(iEndYear,iEndMonth,iEndDay:Word;iStartYear:Word;iStartMonth:Word;iStartDay:Word):Longword;

Implementation

Function Year(MyDate: TDateTime): Word;
Begin
result := StrToInt(FormatDateTime('yyyy', MyDate)); //SetDates(MyDate, 1);
End;

Function Month(MyDate: TDateTime): Word;
Begin
result := StrToInt(FormatDateTime('mm', MyDate)); //SetDates(MyDate, 2);
End;

Function day(MyDate: TDateTime): Word;
Begin
result := StrToInt(FormatDateTime('dd', MyDate)); //SetDates(MyDate, 3);
End;

//日期是该年的第几天，1月1日为第一天

Function DaysNumberOfDate(Date: TDate): Integer;
Var
DaysNumber: Integer;
I: Integer;
yyyy, mm, dd: Word;
Begin
//Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
DecodeDate(Date, yyyy, mm, dd);
DaysNumber := 0;
For I := 1 To mm - 1 Do
Inc(DaysNumber, MonthDays);
Inc(DaysNumber, dd);
Result := DaysNumber;
End;

//日期的农历日期，返回农历格式：月份*100 + 日，负数为闰月
//超出范围则返回0

Function GetAnimal(Date: TDate): integer; //返回十二生肖
Var
Animal: String;
Begin
Animal := CnanimalOfYear(Date);
If Animal = '子鼠' Then
result := 0;

If Animal = '丑牛' Then
result := 1;

If Animal = '寅虎' Then
result := 2;

If Animal = '卯兔' Then
result := 3;

If Animal = '辰龙' Then
result := 4;

If Animal = '巳蛇' Then
result := 5;

If Animal = '午马' Then
result := 6;

If Animal = '未羊' Then
result := 7;

If Animal = '申猴' Then
result := 8;

If Animal = '酉鸡' Then
result := 9;

If Animal = '戌狗' Then
result := 10;

If Animal = '亥猪' Then
result := 11;

End;

Function CnDateOfDate(Date: TDate): Integer;
Var
CnMonth, CnMonthDays: Array Of Integer;
CnBeginDay, LeapMonth: Integer;
yyyy, mm, dd: Word;
Bytes: Array Of Byte;
I: Integer;
CnMonthData: Word;
DaysCount, CnDaysCount, ResultMonth, ResultDay: Integer;
Begin
//Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
DecodeDate(Date, yyyy, mm, dd);
If (yyyy < 1901) Or (yyyy > 2050) Then
Begin
   Result := 0;
   Exit;
End;
Bytes := CnData[(yyyy - 1901) * 4];
Bytes := CnData[(yyyy - 1901) * 4 + 1];
Bytes := CnData[(yyyy - 1901) * 4 + 2];
Bytes := CnData[(yyyy - 1901) * 4 + 3];
If (Bytes And $80) <> 0 Then
CnMonth := 12
Else
CnMonth := 11;
CnBeginDay := (Bytes And $7F);
CnMonthData := Bytes;
CnMonthData := CnMonthData Shl 8;
CnMonthData := CnMonthData Or Bytes;
LeapMonth := Bytes;

For I := 15 Downto 0 Do
Begin
   CnMonthDays := 29;
   If ((1 Shl I) And CnMonthData) <> 0 Then
   Inc(CnMonthDays);
   If CnMonth = LeapMonth Then
   CnMonth := -LeapMonth
   Else
   Begin
      If CnMonth < 0 Then //上月为闰月
         CnMonth := -CnMonth + 1
      Else
         CnMonth := CnMonth + 1;
      If CnMonth > 12 Then CnMonth := 1;
   End;
End;

DaysCount := DaysNumberOfDate(Date) - 1;
If DaysCount <= (CnMonthDays - CnBeginDay) Then
Begin
   If (yyyy > 1901) And
   (CnDateOfDate(EncodeDate(yyyy - 1, 12, 31)) < 0) Then
   ResultMonth := -CnMonth
   Else
   ResultMonth := CnMonth;
   ResultDay := CnBeginDay + DaysCount;
End
Else
Begin
   CnDaysCount := CnMonthDays - 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 CnMonth(Date: TDate): Integer;
Begin
Result := Abs(CnDateOfDate(Date) Div 100);
End;

Function CnMonthOfDate(Date: TDate; Days: Integer): String;
Var
Year, Month, Day: word;
Begin
DecodeDate(Date, Year, Month, Day);
Result := CnMonthOfDate(EncodeDate(Year, Month, Days));

End;

Function CnMonthOfDate(Date: TDate): String;
Const
CnMonthStr: Array Of String = (
'正', '二', '三', '四', '五', '六', '七', '八', '九', '十',
'冬', '腊');
Var
Month: Integer;
Begin
//Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
Month := CnDateOfDate(Date) Div 100;
If Month < 0 Then
Result := '闰' + CnMonthStr[-Month]
Else
Result := CnMonthStr + '月';
End;

Function CnDayOfDatePH(Date: TDate): String;
Const
CnDayStr: Array Of String = (
'初一', '初二', '初三', '初四', '初五',
'初六', '初七', '初八', '初九', '初十',
'十一', '十二', '十三', '十四', '十五',
'十六', '十七', '十八', '十九', '二十',
'廿一', '廿二', '廿三', '廿四', '廿五',
'廿六', '廿七', '廿八', '廿九', '三十');
Var
Day: Integer;
Begin
//Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
Day := Abs(CnDateOfDate(Date)) Mod 100;
Result := CnDayStr;
End;

Function CnDateOfDateStr(Date: TDate): String;
Begin
Result := CnMonthOfDate(Date) + CnDayOfDatePH(Date);
End;

Function CnDayOfDate(Date: TDate; Days: integer; ShowDate: Boolean = false): String; //指定日期的农历日包括节日
Var
Year, Month, Day: word;
Begin
DecodeDate(Date, Year, Month, Day);
Result := CnDayOfDate(EncodeDate(Year, Month, Days));

End;

Function CnDayOfDate(Year,Month,Day: integer): String; overload; //指定日期的农历日包括节日
Begin
Result := CnDayOfDate(EncodeDate(Year, Month, Day));
End;

Function CnDay(Date: TDate): Integer;
Begin
Result := Abs(CnDateOfDate(Date)) Mod 100;
End;

Function CnDayOfDate(Date: TDate): String;
Const
CnDayStr: Array Of String = (
'初一', '初二', '初三', '初四', '初五',
'初六', '初七', '初八', '初九', '初十',
'十一', '十二', '十三', '十四', '十五',
'十六', '十七', '十八', '十九', '二十',
'廿一', '廿二', '廿三', '廿四', '廿五',
'廿六', '廿七', '廿八', '廿九', '三十');
Var
Day: Integer;
Begin
//Date := StrToDate(FormatDateTime('yyyy/mm/dd', Date));
Day := Abs(CnDateOfDate(Date)) Mod 100;
Result := CnDayStr;

End;

Function CnDateOfDateStrPH(Date: TDate): String;
Begin
Result := CnMonthOfDate(Date) + CnDayOfDate(Date);
End;

Function CnDayOfDateJr(Date: TDate; Days: Integer): String;
Var
Year, Month, Day: word;
Begin
DecodeDate(Date, Year, Month, Day);
Result := CnDayOfDateJr(EncodeDate(Year, Month, Days));

End;

Function CnDayOfDateJr(Date: TDate): String;
Var
Day: Integer;
Begin
Result := '';
Day := Abs(CnDateOfDate(Date)) Mod 100;
Case Day Of
1:
   If (CnMonthOfDate(Date) = '正月') Then
   Result := '春节';
5:
   If CnMonthOfDate(Date) = '五月' Then
   Result := '端午节';
7:
   If CnMonthOfDate(Date) = '七月' Then
   Result := '七夕节';
15:
   If CnMonthOfDate(Date) = '八月' Then
   Result := '中秋节'
   Else
   If (CnMonthOfDate(Date) = '正月') Then
      Result := '元宵节';
9:
   If CnMonthOfDate(Date) = '九月' Then
   Result := '重阳节';
8:
   If CnMonthOfDate(Date) = '腊月' Then
   Result := '腊八节';
Else
If (CnMonthOfDate(Date + 1) = '正月') And (CnMonthOfDate(Date) <> '正月') Then
   Result := '除夕';
End; {case}
End;

Function CnanimalOfYear(Date: TDate): String; //返回十二生肖
Var
i: integer;
DateStr: String;
Begin
DateStr := FormatDateTime('yyyy/mm/dd', Date);
i := length(inttostr(month(date)));
Case (StrToInt(Copy(DateStr, 1, 4)) - StrToInt(BaseAnimalDate))
Mod 12 Of
0:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '子鼠'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '亥猪'
      Else
         Result := '子鼠';
   End;
1, -11:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '丑牛'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '子鼠'
      Else
         Result := '丑牛';
   End;
2, -10:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '寅虎'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '丑牛'
      Else
         Result := '寅虎';
   End;
3, -9:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '卯兔'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '寅虎'
      Else
         Result := '卯兔';
   End;
4, -8:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '辰龙'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '卯兔'
      Else
         Result := '辰龙';
   End;
5, -7:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '巳蛇'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '辰龙'
      Else
         Result := '巳蛇';
   End;
6, -6:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '午马'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '巳蛇'
      Else
         Result := '午马';
   End;
7, -5:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '未羊'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '午马'
      Else
         Result := '未羊';
   End;
8, -4:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '申猴'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '未羊'
      Else
         Result := '申猴';
   End;
9, -3:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '酉鸡'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '申猴'
      Else
         Result := '酉鸡';
   End;
10, -2:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '戌狗'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '酉鸡'
      Else
         Result := '戌狗';
   End;
11, -1:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '亥猪'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '戌狗'
      Else
         Result := '亥猪';
   End;
End; {case}
End;

Function CnSkyStemOfYear(Date: TDate): String; //返回十大天干
Var
i: integer;
DateStr: String;
Begin
DateStr := FormatDateTime('yyyy/mm/dd', Date);
i := length(inttostr(month(date)));
Case (StrToInt(Copy(DateStr, 1, 4)) - StrToInt(BaseSkyStemDate))
Mod 10 Of
0:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '甲'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '癸'
      Else
         Result := '甲';
   End;
1, -9:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '乙'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '甲'
      Else
         Result := '乙';
   End;
2, -8:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '丙'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '乙'
      Else
         Result := '丙';
   End;
3, -7:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '丁'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '丙'
      Else
         Result := '丁';
   End;
4, -6:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '戊'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '丁'
      Else
         Result := '戊';
   End;
5, -5:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '巳'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '戊'
      Else
         Result := '巳';
   End;
6, -4:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '庚'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '巳'
      Else
         Result := '庚';
   End;
7, -3:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '辛'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '庚'
      Else
         Result := '辛';
   End;
8, -2:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '壬'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '辛'
      Else
         Result := '壬';
   End;
9, -1:
   If (StrToInt(Copy(DateStr, 6, i)) < 4) And ((Pos('腊',
   CnMonthOfDate(Date)) = 0) And (Pos('冬', CnMonthOfDate(Date)) = 0)) Then
   Result := '癸'
   Else
   Begin
      If StrToInt(Copy(DateStr, 6, i)) < 4 Then
         Result := '壬'
      Else
         Result := '癸';
   End;
End;
Result := Result + Copy(CnanimalOfYear(Date), 1, 3);
End;

Function CnSolarTerm(Date: TDate): String; //返回十大天干
Var
Year, Month, Day, Hour: Word;
Begin
DecodeDate(Date, Year, Month, Day);
//d:=( ( 31556925974.7*(Year-1900) + SolarTerm*60000) + Date(1900,0,6,2,5) );

End;

Function GetLunarHolDay(InDate: TDateTime; Days: Integer): String;
Var
Year, Month, Day, Hour: Word;
Begin
DecodeDate(Date, Year, Month, Day);
Result := GetLunarHolDay(EncodeDate(Year, Month, Days));

End;

Function GetLunarHolDay(InDate: TDateTime): String;
Var
i, iYear, iMonth, iDay: Word;
Begin
//InDate := StrToDate(FormatDateTime('yyyy/mm/dd', InDate));

Result := '';
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 := '冬至';
End;
End;

Function l_GetLunarHolDay(iYear, iMonth, iDay: Word): Word;
Var
Flag: Byte;
Day: Word;
Begin
//var offDate = new Date( ( 31556925974.7*(y-1900) + sTermInfo*60000) + Date.UTC(1900,0,6,2,5) )
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 OtherHoliday(Month, Day: integer): String;
Begin
//五月的第二个星期日庆祝母亲节
//將每年6月的第3個星期天定為父親節    ?
{

新年元旦腊八节[农历十二月初八]

世界湿地日国际气象节情人节
除夕[农历十二月三十] 春节[农历正月初一] 元宵节[农历正月十五]

全国爱耳日妇女节植树节
国际警察日国际消费日世界森林日
世界水日世界气象日世界防治结核病日

愚人节清明世界卫生日
世界地球日

国际劳动节中国青年节全国碘缺乏病日
世界红十字日国际护士节国际家庭日
世界电信日国际博物馆日全国助残日
全国学生营养日国际生物多样性日国际牛奶日
世界无烟日端午节[农历五月初五] 母亲节[第二个星期日]

国际儿童节世界环境日全国爱眼日
端午节父亲节[第三个星期日] 防治荒漠化和干旱日
国际奥林匹克日全国土地日国际反毒品日

香港回归日七夕情人节[农历七月初七] 建党日　
中国人民抗日战争纪念日世界人口日　

八一建军节　　

劳动节　国际扫盲日教师节
国际臭氧层保护日国际和平日国际爱牙日
中秋节[农历八月十五] 国际聋人节世界旅游日
重阳节[农历九月九日]

国庆节　国际音乐节国际减轻自然灾害日
世界动物日国际住房日全国高血压日
世界视觉日世界邮政日世界精神卫生日
国际盲人节世界粮食节世界消除贫困日
世界传统医药日联合国日万圣节

中国记者日　消防宣传日世界糖尿病日
国际大学生节感恩节

冬至节[农历12月22日] 世界艾滋病日世界残疾人日
世界足球日圣诞节

}
result := '';

Case Month Of
1:
   Begin
   End;

2:
   Begin

   If day = 2 Then
      result := '湿地日';

   If day = 10 Then
      result := '气象节';

   End;
3:
   Begin
   If day = 3 Then
      result := '爱耳日';

   If day = 12 Then
      result := '植树节';

   If day = 14 Then
      result := '警察日';

   If day = 15 Then
      result := '消费节';

   If day = 21 Then
      result := '森林日';

   If day = 22 Then
      result := '水日';

   If day = 23 Then
      result := '气象日';

   End;
4:
   Begin

   If day = 7 Then
      result := '卫生日';

   If day = 22 Then
      result := '地球日';

   End;
5:
   Begin
   If day = 8 Then
      result := '红十字';

   If day = 12 Then
      result := '护士节';

   If day = 15 Then
      result := '家庭日';

   If day = 17 Then
      result := '电信日';

   If day = 18 Then
      result := '博物馆';

   If day = 19 Then
      result := '助残日';

   If day = 23 Then
      result := '牛奶日';

   If day = 31 Then
      result := '无烟日';

   // 母亲节[第二个星期日]
   End;
6:
   Begin

   If day = 5 Then
      result := '环境日';

   If day = 6 Then
      result := '爱眼日';

   If day = 23 Then
      result := '体育日';

   If day = 25 Then
      result := '土地日';

   If day = 26 Then
      result := '反毒品';

   // 父亲节[第三个星期日]
   End;
7:
   Begin

   If day = 11 Then
      result := '人口日';

   End;
8:
   Begin

   End;
9:
   Begin
   If day = 8 Then
      result := '扫盲日';

   If day = 17 Then
      result := '和平日';

   If day = 20 Then
      result := '爱牙日';

   If day = 22 Then
      result := '聋人节';

   If day = 27 Then
      result := '旅游日';

   End;
10:
   Begin

   If day = 6 Then
      result := '老人节';

   If day = 4 Then
      result := '动物日';

   If day = 7 Then
      result := '住房日';

   If day = 9 Then
      result := '邮政日';

   If day = 15 Then
      result := '盲人节';

   If day = 16 Then
      result := '粮食日';

   End;

11:
   Begin
   If day = 8 Then
      result := '记者日';

   If day = 9 Then
      result := '消防日';

   If day = 17 Then
      result := '大学生';

   End;
12:
   Begin
   If day = 9 Then
      result := '足球日';

   If day = 24 Then
      result := '平安夜';
   End;

End;
End;

Function Holiday(Date: TDateTime; Day: integer): String;
Var
dDate: TDate;
Begin
result := '';
//result := OtherHoliday(Month(Date), Day);

Case Month(Date) Of
1:
   Begin
   If day = 1 Then
      result := '元旦节';
   End;

2:
   Begin
   If day = 14 Then
      result := '情人节';
   End;
3:
   Begin
   If day = 8 Then
      result := '妇女节';
   End;
4:
   Begin
   If day = 1 Then
      result := '愚人节';
   End;
5:
   Begin
   If day = 1 Then
      result := '劳动节';

   If day = 4 Then
      result := '青年节';

   // 母亲节[第二个星期日]
   dDate := EnCodeDate(Year(Date), Month(Date), Day);
   If (DayOfWeek(dDate) = 1) Then
      If (Trunc((Day - 1) / 7) = 1) Then
         result := '母亲节';

   End;
6:
   Begin
   If day = 1 Then
      result := '儿童节';

   // 父亲节[第三个星期日]
   dDate := EnCodeDate(Year(Date), Month(Date), Day);
   If (DayOfWeek(dDate) = 1) Then
      If (Trunc((Day - 1) / 7) = 2) Then
         result := '父亲节';
   End;
7:
   Begin
   If day = 1 Then
      result := '建党节';
   End;
8:
   Begin
   If day = 1 Then
      result := '建军节';

   End;
9:
   Begin
   If day = 10 Then
      result := '教师节';
   End;
10:
   Begin
   If day = 1 Then
      result := '国庆节';

   If day = 6 Then
      result := '老人节';

   If day = 31 Then
      result := '万圣节';

   End;

11:
   Begin
   If day = 8 Then
      result := '记者日';

   // 感恩节(11月的第四个星期四 )
   dDate := EnCodeDate(Year(Date), Month(Date), Day);
   If (DayOfWeek(dDate) = 5) Then
      If (Trunc((Day - 1) / 7) = 3) Then
         result := '感恩节';

   End;
12:
   Begin
   If day = 25 Then
      result := '圣诞节';
   End;

End;
End;

Function GetCnDateToDate(dDate: TDateTime): TDateTime;
Begin
Result := GetCnDateToDate(Year(Now), CnMonth(dDate), CnDay(dDate));
End;

Function GetCnDateToDate(cYear, cMonth, cDay: word): TDateTime;
Var
tempDate: TDateTime;
tempDay, tempMonth: Integer;

Begin
If cMonth > 11 Then
tempDate := EnCodeDate(cYear - 1, cMonth, cDay)
Else
tempDate := EnCodeDate(cYear, cMonth, cDay);

Result := 0;
tempMonth := 0;
tempDay := 0;
While Result = 0 Do
Begin
   tempDate := tempDate + 1;

   If CnMonth(tempDate) = cMonth Then
   If CnDay(tempDate) = cDay Then
      Begin
         Result := tempDate;
         exit;
      End
   Else
      If (cDay = 30) And (CnDay(tempDate) = 29)
         And (CnDay(tempDate + 1) <> 30) Then
         Begin
         //如果是没有30(闰月)，就提前一天
         Result := tempDate;
         exit;
         End;

End;
End;

Function GetDays(ADate: TDate): Extended;
Var
FirstOfYear: TDateTime;
Begin
FirstOfYear := EncodeDate(StrToInt(FormatDateTime('yyyy', now)) - 1, 12, 31);
Result := ADate - FirstOfYear;
End;

Function Constellation(Date: TDateTime; Day: integer): String; overload;
Var
Year, Month, Days, Hour: Word;
Begin
DecodeDate(Date, Year, Month, Days);
Result := Constellation(EncodeDate(Year, Month, Day));
end;

Function Constellation(ADate: TDate): String;
Begin
Case Month(ADate) Of
1:
   Begin
   If day(ADate) <= 19 Then
      result := '摩羯座';

   If day(ADate) >= 20 Then
      result := '水瓶座';
   End;

2:
   Begin
   If day(ADate) <= 18 Then
      result := '水瓶座';

   If day(ADate) >= 19 Then
      result := '双鱼座';
   End;

3:
   Begin
   If day(ADate) <= 20 Then
      result := '双鱼座';

   If day(ADate) >= 21 Then
      result := '白羊座';
   End;

4:
   Begin
   If day(ADate) <= 19 Then
      result := '白羊座';

   If day(ADate) >= 20 Then
      result := '金牛座';
   End;

5:
   Begin
   If day(ADate) <= 20 Then
      result := '金牛座';

   If day(ADate) >= 21 Then
      result := '双子座';
   End;

6:
   Begin
   If day(ADate) <= 21 Then
      result := '双子座';

   If day(ADate) >= 22 Then
      result := '巨蟹座';
   End;

7:
   Begin
   If day(ADate) <= 22 Then
      result := '巨蟹座';

   If day(ADate) >= 23 Then
      result := '狮子座';
   End;

8:
   Begin
   If day(ADate) <= 22 Then
      result := '狮子座';

   If day(ADate) >= 24 Then
      result := '处女座';
   End;

9:
   Begin
   If day(ADate) <= 22 Then
      result := '处女座';

   If day(ADate) >= 23 Then
      result := '天秤座';
   End;

10:
   Begin
   If day(ADate) <= 23 Then
      result := '天秤座';

   If day(ADate) >= 24 Then
      result := '天蝎座';
   End;

11:
   Begin
   If day(ADate) <= 21 Then
      result := '天蝎座';

   If day(ADate) >= 22 Then
      result := '射手座';
   End;

12:
   Begin
   If day(ADate) <= 21 Then
      result := '射手座';

   If day(ADate) >= 22 Then
      result := '摩羯座';
   End;
End;
End;
{
//存储星座配信息
1白羊座： 03月21日-------04月19日Aries
2金牛座： 04月20日-------05月20日Taurus
3双子座： 05月21日-------06月21日Gemini
4巨蟹座： 06月22日-------07月22日Cancer
5狮子座： 07月23日-------08月22日Leo
6处女座： 08月23日-------09月22日Virgo
7天秤座： 09月23日-------10月23日Libra
8天蝎座： 10月24日-------11月21日Scorpio
9射手座： 11月22日-------12月21日Sagittarius
10摩羯座： 12月22日-------01月19日Capricorn
11水瓶座： 01月20日-------02月18日Aquarius
12双鱼座： 02月19日-------03月20日Pisces
}
End.

黑夜彩虹 发表于 2006-6-4 22:49:28

DateWin.pas

DateWin.pas
unit DateWin;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, ComCtrls, DateUtils;

type
TFRM_Date = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
day1: TLabel;
Cnday: TLabel;
Label9: TLabel;
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
Label13: TLabel;
Label14: TLabel;
Label15: TLabel;
Bevel1: TBevel;
Bevel2: TBevel;
Label16: TLabel;
Label17: TLabel;
Label18: TLabel;
Label19: TLabel;
Shape2: TShape;
UpDown1: TUpDown;
UpDown2: TUpDown;
Label20: TLabel;
StaticText1: TStaticText;
Label21: TLabel;
Label22: TLabel;
Image1: TImage;
Shape1: TShape;
//CnDayClick
procedure CnDayClick(Sender: TObject);
procedure CHnDayClick(Sender: TObject);
procedure Label1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
procedure Label17Click(Sender: TObject);
procedure UpDown2Click(Sender: TObject; Button: TUDBtnType);
procedure Label5Click(Sender: TObject);
procedure FormDeactivate(Sender: TObject);
procedure CnDayMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
procedure ChnDateMouseDown(Sender: TObject; Button: TMouseButton;
   Shift: TShiftState; X, Y: Integer);
procedure StaticText1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormPaint(Sender: TObject);

private
{ Private declarations }
procedure LoadLAB;
procedure DateChange(MyTime: TDateTime);
procedure OK;
public
{ Public declarations }
FPicture_AlphaBlend: Byte;
FPicture: TbitMap;
NDate: Tdate;
YearEdit, MonthEdit, DayEdit: TEdit;
ChDateLabel: TLabel;

procedure ShowDateWin(YearEdit1, MonthEdit1, DayEdit1: TEdit; {ChDateLabel1: TLabel;} HostControl: TControl; Bmp: TBitMap = nil; iAlphaBlend: Byte = 150);
end;

var
FRM_Date: TFRM_Date;
CnDate: array of TLabel;
ChnDate: array of TLabel;
NYear, NMonth, NDay: Word;
MHostControl: TControl;
implementation

uses DateCn, ChnCalendar;

{$R *.DFM}

function FormExists(FORM_NAME: string): BOOLEAN;
begin
if Application.FindComponent(FORM_NAME) = nil then
RESULT := FALSE
else
RESULT := TRUE;
end;

function DayOfMonth(Year, Month: Integer): integer; overload;
begin
try
Result := MonthDays;
except
Result := 0;
end;
end;

function DayOfMonth(Dates: TDateTime): integer; overload;
var
Year, Month, Day, Hour: Word;

begin
DecodeDate(Dates, Year, Month, day);
Result := MonthDays;
end;

function DaysOfMonth(Dates: TDateTime): Integer;
begin
Result := DayOfMonth(YearOf(Dates), MonthOf(Dates));
end;

function SetDateTime(NYear, NMonth, NDay: Word): TDate;
var
MyDay: Word;
begin
MyDay := DayOfMonth(NYear, NMonth);
if MyDay < NDay then
NDay := MyDay;
Result := EncodeDate(NYear, NMonth, NDay);

end;

procedure TFRM_Date.Label1Click(Sender: TObject);
begin
//Self.Close ;
UpDown1.Visible := true;
UpDown2.Visible := false;

end;

procedure TFRM_Date.LoadLAB;
var
i: integer;
begin

for i := 1 to 37 do
begin
CnDate := TLabel.Create(self);
CnDate.parent := self;
ChnDate := TLabel.Create(self);
ChnDate.parent := self;

CnDate.OnClick := CnDayClick;
CnDate.OnMouseDown := CnDayMouseDown;
ChnDate.OnClick := ChnDayClick;
ChnDate.OnMouseDown := ChnDateMouseDown;
CnDate.AutoSize := false;
ChnDate.AutoSize := false;
CnDate.Width := day1.Width;
ChnDate.Width := Cnday.Width;
CnDate.Height := day1.Height;
ChnDate.Height := Cnday.Height;
CnDate.Alignment := day1.Alignment;
ChnDate.Alignment := Cnday.Alignment;
CnDate.Layout := day1.Layout;
ChnDate.Layout := Cnday.Layout;

if i = 1 then
begin
   CnDate.Left := day1.Left;
   CnDate.Top := day1.Top;
   ChnDate.Left := Cnday.Left;
   ChnDate.Top := Cnday.Top;

end
else
begin

   if ((i - 1) / 7) = ((i - 1) div 7) then
   begin
   CnDate.Top := CnDate.Top + 32;
   CnDate.Left := day1.Left;
   ChnDate.Top := ChnDate.Top + 32;
   ChnDate.Left := Cnday.Left;

   end
   else
   begin

   CnDate.Top := CnDate.Top;
   CnDate.Left := CnDate.Left + 42;
   ChnDate.Top := ChnDate.Top;
   ChnDate.Left := ChnDate.Left + 42;

   end;
end;
CnDate.Font := day1.Font;
ChnDate.Font := Cnday.Font;
CnDate.Font.Color := clBlack;
CnDate.AutoSize := false;
ChnDate.AutoSize := false;
CnDate.Transparent := true;
ChnDate.Transparent := true;

   //    CnDate.Caption :='22';
   //    CnDate.Visible:=true;
   //    ChnDate.Caption :='初一';

end;

end;

procedure TFRM_Date.DateChange(MyTime: TDateTime);
var
i, S: integer;
StarNo: integer;
Present: TDateTime;
Year, Month, Day, Hour: Word;

begin
//Label6.Caption :=datetostr(MyTime);
//Label14.Caption :='今天:'+datetostr(date);
//MyDates:=MyTime;
Label20.Caption := IntToStr(DateUtils.YearOf(Mytime));
Label17.Caption := IntToStr(DateUtils.MonthOf(Mytime));
Label16.Caption := Label17.Caption;
Label1.Caption := IntToStr(DateUtils.YearOf(Mytime));
Label21.Caption := CnanimalOfYear(Mytime);

for i := 1 to 37 do
begin
CnDate.Visible := false;
ChnDate.Visible := false;
ChnDate.Font.Color := clBlack;
CnDate.Font.Color := clBlack;
CnDate.Font.Size := 11;
CnDate.Color := self.Color;
ChnDate.Color := self.Color;
end;

DecodeDate(MyTime, Year, Month, Day);
Present := EncodeDate(Year, Month, 1);
StarNo := dayofweek(Present);
s := starno + DayOfMonth(Present) - 1;
try
for i := StarNo to s do
begin
   Present := EncodeDate(Year, Month, i - StarNo + 1);
   CnDate.Caption := IntToStr(i - StarNo + 1);
   CnDate.Tag := i - StarNo + 1;
   ChnDate.Tag := CnDate.Tag;
   ChnDate.Caption := CnDayOfDate(Present);
   if ChnDate.Caption = '初一' then
   begin
   ChnDate.Caption := CnMonthOfDate(Present);
   ChnDate.Font.Color := clRed;
   end
   else
   ChnDate.Font.Color := Cnday.Font.Color;
   if length(Holiday(MyTime, i - StarNo + 1)) > 3 then
   begin
   ChnDate.Caption := Holiday(MyTime, i - StarNo + 1);
   ChnDate.Font.Color := $000080FF;
   end;
   if DateCn.GetLunarHolDay(Present) <> '' then
   begin
   ChnDate.Caption := GetLunarHolDay(Present);
   ChnDate.Font.Color := $00FF5353;
   end;
   if DateCn.CnDayOfDateJr(Present) <> '' then
   begin
   ChnDate.Caption := CnDayOfDateJr(Present);
   ChnDate.Font.Color := $000080FF;
   end;
   if i - StarNo + 1 = day then
   begin

   Shape2.Left := CnDate.left - 1;
   Shape2.Top := CnDate.top + 1;
   Label22.Caption := Constellation(Present, day);
   end;

   CnDate.Visible := true;
   ChnDate.Visible := true;

end;

except
on EConvertError do
begin
   // showmessage(inttostr(i));
   exit;
end
else exit;
end;

end;

procedure TFRM_Date.FormCreate(Sender: TObject);
begin
LoadLAB;
NDate := Date;

end;

procedure TFRM_Date.FormShow(Sender: TObject);
begin
DecodeDate(NDate, NYear, NMonth, NDay);
UpDown1.Position := NYear;
UpDown2.Position := NMonth;

DateChange(NDate);
end;

procedure TFRM_Date.CHnDayClick(Sender: TObject);
begin
Label5Click(nil);
Nday := (sender as TLabel).Tag;
OK;
end;

procedure TFRM_Date.CnDayClick(Sender: TObject);
begin
Label5Click(nil);
Nday := (sender as TLabel).Tag;
OK;

end;

procedure TFRM_Date.UpDown1Click(Sender: TObject; Button: TUDBtnType);
var
Present: TDate;
begin
NYear := UpDown1.Position;
Present := SetDateTime(NYear, NMonth, NDay);
DateChange(Present);
end;

procedure TFRM_Date.Label17Click(Sender: TObject);
begin
UpDown2.Visible := true;
UpDown1.Visible := false;
end;

procedure TFRM_Date.UpDown2Click(Sender: TObject; Button: TUDBtnType);
var
Present: TDate;
begin
NMonth := UpDown2.Position;
Present := SetDateTime(NYear, NMonth, NDay);
DateChange(Present);

end;

procedure TFRM_Date.Label5Click(Sender: TObject);
begin
UpDown2.Visible := False;
UpDown1.Visible := false;

end;

procedure TFRM_Date.FormDeactivate(Sender: TObject);
begin
Self.Close;
end;

procedure TFRM_Date.ChnDateMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Shape2.Left := (sender as TLabel).left;
Shape2.Top := (sender as TLabel).top - 16;

end;

procedure TFRM_Date.CnDayMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Shape2.Left := (sender as TLabel).left - 1;
Shape2.Top := (sender as TLabel).top + 1;

end;

procedure TFRM_Date.StaticText1Click(Sender: TObject);
begin
NDate := Date;
FormShow(nil);
end;

procedure TFRM_Date.OK;
begin
NDate := EncodeDate(NYear, NMonth, NDay);
//TChnCalendar(MHostControl).IsInit := False;
TChnCalendar(MHostControl).DateTime := NDate;
Close;
end;

procedure TFRM_Date.ShowDateWin(YearEdit1, MonthEdit1, DayEdit1: TEdit;
HostControl: TControl; Bmp: TBitMap = nil; iAlphaBlend: Byte = 150);
var
P: TPoint;
FBackPicture: TbitMap;
begin
{if not FormExists('FRM_Date') then
Self := TFRM_Date.Create(Application);
YearEdit := YearEdit1;
MonthEdit := MonthEdit1;
DayEdit := DayEdit1;
//ChDateLabel := ChDateLabel1;
MHostControl := HostControl;

YearEdit.Text := IntToStr(StrTOIntDef(YearEdit.Text, YearOf(Date)));
MonthEdit.Text := IntToStr(StrTOIntDef(MonthEdit.Text, MonthOf(Date)));
DayEdit.Text := IntToStr(StrTOIntDef(DayEdit.Text, DayOfMonth(Date)));

if (StrToInt(YearEdit.Text) > 2050) or (StrToInt(YearEdit.Text) < 1901) then
YearEdit.Text := IntToStr(YearOf(Date));

if (StrToInt(MonthEdit.Text) > 12) or (StrToInt(MonthEdit.Text) < 1) then
MonthEdit.Text := IntToStr(MonthOf(Date));

if StrToInt(DayEdit.Text) > DayOfMonth(StrToInt(YearEdit.Text), StrToInt(MonthEdit.Text)) then
DayEdit.Text := IntToStr(DayOfMonth(StrToInt(YearEdit.Text), StrToInt(MonthEdit.Text)));

NDate := EncodeDate(StrToInt(YearEdit.text), StrToInt(MonthEdit.text), StrToInt(DayEdit.text));
AdjustDropDownForm(Self, HostControl);

Image1.Picture.Bitmap.Assign(Bmp);
Label16.Visible := Image1.Picture.Graphic = nil;
Label20.Visible := Image1.Picture.Graphic = nil;
if Image1.Picture.Graphic <> nil then
begin
FBackPicture := TbitMap.Create;
FBackPicture.Width := Image1.Width ;
FBackPicture.Height := Image1.Height;
FBackPicture.Canvas.Brush.Color := Color;
FBackPicture.Canvas.FillRect(RECT(0, 0, FBackPicture.Width,
   FBackPicture.Height));

P := Point((FBackPicture.Width - bmp.Width) div 2,
   (FBackPicture.Height - bmp.Height) div 2);
BmpAlphaBlend(FBackPicture, Bmp, P, iAlphaBlend);
Image1.Canvas.Draw(0, 0, FBackPicture);
FBackPicture.free;

end;
Self.Show;}
end;

procedure TFRM_Date.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Application.RemoveComponent(Self);
Self := nil;
Self.Free;

end;

procedure TFRM_Date.FormPaint(Sender: TObject);
var
P: TPoint;
FBackPicture: TbitMap;
begin
//
                     {
if not FPicture.Empty then
begin
FBackPicture := TbitMap.Create;
FBackPicture.Width := ClientWidth;
FBackPicture.Height := ClientHeight;
FBackPicture.Canvas.Brush.Color := Color;
FBackPicture.Canvas.FillRect(RECT(0, 0, FBackPicture.Width,
   FBackPicture.Height));

P := Point((FBackPicture.Width - FPicture.Width) div 2,
   (FBackPicture.Height - FPicture.Height) div 2);
BmpAlphaBlend(FBackPicture, FPicture, P, FPicture_AlphaBlend);
Canvas.Draw(0, 0, FBackPicture);
FBackPicture.free;
end;
}
end;

end.

黑夜彩虹 发表于 2006-6-4 22:50:17

DateWin.dfm

DateWin.dfm
object FRM_Date: TFRM_Date
Left = 568
Top = 125
BorderStyle = bsNone
Caption = 'FRM_Date'
ClientHeight = 274
ClientWidth = 313
Color = clWhite
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
OldCreateOrder = False
OnClose = FormClose
OnCreate = FormCreate
OnDeactivate = FormDeactivate
OnPaint = FormPaint
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 12
object Shape1: TShape
Left = 0
Top = 0
Width = 313
Height = 274
Align = alClient
end
object Image1: TImage
Left = 9
Top = 56
Width = 297
Height = 191
end
object Label20: TLabel
Left = 0
Top = 56
Width = 313
Height = 72
Alignment = taCenter
AutoSize = False
Caption = '2002'
Font.Charset = ANSI_CHARSET
Font.Color = 14543103
Font.Height = -64
Font.Name = 'Arial Black'
Font.Style = []
ParentFont = False
Transparent = True
Layout = tlCenter
end
object Label16: TLabel
Left = 0
Top = 98
Width = 313
Height = 134
Alignment = taCenter
AutoSize = False
Caption = '6'
Font.Charset = ANSI_CHARSET
Font.Color = 15461355
Font.Height = -120
Font.Name = 'Arial Black'
Font.Style = []
ParentFont = False
Transparent = True
Layout = tlCenter
end
object Bevel2: TBevel
Left = 9
Top = 46
Width = 297
Height = 10
Shape = bsBottomLine
end
object Shape2: TShape
Left = 12
Top = 56
Width = 38
Height = 30
Brush.Color = 8512126
end
object Label1: TLabel
Left = 120
Top = 0
Width = 76
Height = 41
Cursor = crHandPoint
Hint = #21333#20987#25913#21464#24180#20221
Alignment = taCenter
Caption = '2002'
Color = 15268607
Font.Charset = ANSI_CHARSET
Font.Color = clBlue
Font.Height = -29
Font.Name = 'Arial Black'
Font.Style = []
ParentColor = False
ParentFont = False
ParentShowHint = False
ShowHint = True
Transparent = True
Layout = tlCenter
OnClick = Label1Click
end
object Label2: TLabel
Left = 19
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#26085
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object Label3: TLabel
Left = 59
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#19968
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object Label4: TLabel
Left = 99
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#20108
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object Label5: TLabel
Left = 179
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#22235
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object Label6: TLabel
Left = 139
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#19977
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object Label7: TLabel
Left = 259
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#20845
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object Label8: TLabel
Left = 219
Top = 40
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#20116
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
OnClick = Label5Click
end
object day1: TLabel
Left = 14
Top = 56
Width = 36
Height = 16
Alignment = taCenter
AutoSize = False
Caption = '22'
Font.Charset = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -14
Font.Name = 'Arial Black'
Font.Style = []
ParentFont = False
Transparent = True
Layout = tlCenter
Visible = False
end
object Cnday: TLabel
Left = 13
Top = 73
Width = 36
Height = 12
Alignment = taCenter
AutoSize = False
Caption = #21021#19968
Font.Charset = GB2312_CHARSET
Font.Color = 16384
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Transparent = True
Layout = tlCenter
Visible = False
end
object Label9: TLabel
Left = 20
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#26085
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Label10: TLabel
Left = 60
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#19968
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Label11: TLabel
Left = 100
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#20108
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Label12: TLabel
Left = 140
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#19977
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Label13: TLabel
Left = 180
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#22235
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Label14: TLabel
Left = 220
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#20116
Font.Charset = GB2312_CHARSET
Font.Color = clBlack
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Label15: TLabel
Left = 260
Top = 253
Width = 36
Height = 12
Alignment = taCenter
Caption = #26143#26399#20845
Font.Charset = GB2312_CHARSET
Font.Color = clRed
Font.Height = -12
Font.Name = #23435#20307
Font.Style = []
ParentFont = False
Layout = tlCenter
end
object Bevel1: TBevel
Left = 9
Top = 240
Width = 297
Height = 10
Shape = bsBottomLine
end
object Label17: TLabel
Left = 10
Top = 3
Width = 36
Height = 37
Cursor = crHandPoint
Hint = #21333#20987#25913#21464#26376#20221
Alignment = taCenter
Caption = '12'
Font.Charset = ANSI_CHARSET
Font.Color = 12615808
Font.Height = -32
Font.Name = 'Arial'
Font.Style =
ParentFont = False
ParentShowHint = False
ShowHint = True
Transparent = True
OnClick = Label17Click
end
object Label18: TLabel
Left = 45
Top = 20
Width = 15
Height = 14
Caption = #26376
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -14
Font.Name = #23435#20307
Font.Style =
ParentFont = False
end
object Label19: TLabel
Left = 205
Top = 17
Width = 15
Height = 14
Caption = #24180
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -14
Font.Name = #23435#20307
Font.Style =
ParentFont = False
end
object Label21: TLabel
Left = 230
Top = 212
Width = 78
Height = 35
Alignment = taCenter
AutoSize = False
Caption = #26411#40857
Font.Charset = GB2312_CHARSET
Font.Color = 16768477
Font.Height = -35
Font.Name = #38582#20070
Font.Style =
ParentFont = False
Transparent = True
end
object Label22: TLabel
Left = 152
Top = 223
Width = 69
Height = 23
Alignment = taCenter
AutoSize = False
Caption = #26411#40857
Font.Charset = GB2312_CHARSET
Font.Color = 16744703
Font.Height = -19
Font.Name = #40657#20307
Font.Style =
ParentFont = False
Transparent = True
end
object UpDown1: TUpDown
Left = 221
Top = 10
Width = 16
Height = 24
Min = 1901
Max = 2050
Position = 1901
TabOrder = 0
Visible = False
OnClick = UpDown1Click
end
object UpDown2: TUpDown
Left = 61
Top = 10
Width = 16
Height = 24
Min = 1
Max = 12
Position = 12
TabOrder = 1
Visible = False
OnClick = UpDown2Click
end
object StaticText1: TStaticText
Left = 272
Top = 17
Width = 28
Height = 16
Cursor = crHandPoint
Alignment = taCenter
BorderStyle = sbsSingle
Caption = #20170#22825
Color = 13693646
ParentColor = False
TabOrder = 2
OnClick = StaticText1Click
end
end

wpj1122 发表于 2006-6-5 20:39:23

晕了....

xgh163 发表于 2006-6-5 22:07:08

倒了~~~

caterpilla 发表于 2006-6-7 12:42:22

收下了！！！！

野猫III 发表于 2006-6-10 12:32:57

写编程。。。谈何容易呀。。。

fdisk926 发表于 2006-6-13 12:55:49

慌了~~~~~
这么多地~~~
有没有POWERBUILDER 这样的东西啊 ~
学习学习啊~

页: [1]

飘云阁's Archiver

一個超棒的農曆控件 for Delphi

DateCn.pas

DateWin.pas

DateWin.dfm