日历制做(100分)

请求阴阳历对照表，或哪儿有阴阳历控件。

http://www.nease.net/~bozhi/cncalc.zip

tongfeng.yeah.net

给你一个例程：
（我也是抄的，还有节令的呢，你照CUT就是。）

unit CNYear;

interface
uses sysutils;
type TCNDate = Cardinal;
function DecodeGregToCNDate(dtGreg:TDateTime):TCNDate;
function GetGregDateFromCN(cnYear,cnMonth,cnDay:word;bLeap:Boolean=False):TDateTime;
function GregDateToCNStr(dtGreg:TDateTime):String;
function isCNLeap(cnDate:TCNDate):boolean;
implementation
const cstDateOrg:Integer=32900; //公历1990-01-27的TDateTime表示 对应农历1990-01-01
const cstCNYearOrg=1990;
const cstCNTable:array[cstCNYearOrg..cstCNYearOrg + 60] of WORD=( // unsigned 16-bit
24402, 3730, 3366, 13614, 2647, 35542, 858, 1749, //1997
23401, 1865, 1683, 19099, 1323, 2651, 10926, 1386, //2005
32213, 2980, 2889, 23891, 2709, 1325, 17757, 2741, //2013
39850, 1490, 3493, 61098, 3402, 3221, 19102, 1366, //2021
2773, 10970, 1746, 26469, 1829, 1611, 22103, 3243, //2029
1370, 13678, 2902, 48978, 2898, 2853, 60715, 2635, //2037
1195, 21179, 1453, 2922, 11690, 3474, 32421, 3365, //2045
2645, 55901, 1206, 1461, 14038); //2050
//建表方法：
// 0101 111101010010 高四位是闰月位置,后12位表示大小月,大月30天,小月29天,
//闰月一般算小月,但是有三个特例2017/06,2036/06,2047/05
//对于特例则高四位的闰月位置表示法中的最高为设置为1 特殊处理用wLeapNormal变量
// //2017/06 28330->61098 2036/06 27947->60715 2047/05 23133->55901

//如果希望用汇编,这里有一条信息:农历不会滞后公历2个月.
//将公历转换为农历
//返回:12位年份+4位月份+5位日期
function DecodeGregToCNDate(dtGreg:TDateTime):TCNDate;
var
iDayLeave:Integer;
wYear,wMonth,wDay:WORD;
i,j:integer;
wBigSmallDist,wLeap,wCount,wLeapShift:WORD;
label OK;
begin
result := 0;
iDayLeave := Trunc(dtGreg) - cstDateOrg;
DecodeDate(IncMonth(dtGreg,-1),wYear,wMonth,wDay);
if (iDayLeave < 0) or (iDayLeave > 22295 )then Exit;
//Raise Exception.Create('目前只能算1990-01-27以后的');
//Raise Exception.Create('目前只能算2051-02-11以前的');
for i:=Low(cstCNTable) to High(cstCNTable) do begin
wBigSmallDist := cstCNTable;
wLeap := wBigSmallDist shr 12;
if wLeap > 12 then begin
wLeap := wLeap and 7;
wLeapShift := 1;
end else
wLeapShift := 0;
for j:=1 to 12 do begin
wCount:=(wBigSmallDist and 1) + 29;
if j=wLeap then wCount := wCount - wLeapShift;
if iDayLeave < wCount then begin
Result := (i shl 9) + (j shl 5) + iDayLeave + 1;
Exit;
end;
iDayLeave := iDayLeave - wCount;
if j=wLeap then begin
wCount:=29 + wLeapShift;
if iDayLeave < wCount then begin
Result := (i shl 9) + (j shl 5) + iDayLeave + 1 + (1 shl 21);
Exit;
end;
iDayLeave := iDayLeave - wCount;
end;
wBigSmallDist := wBigSmallDist shr 1;
end;
end;
//返回值:
// 1位闰月标志 + 12位年份+4位月份+5位日期 (共22位)
end;
function isCNLeap(cnDate:TCNDate):boolean;
begin
result := (cnDate and $200000) <> 0;
end;
function GetGregDateFromCN(cnYear,cnMonth,cnDay:word;bLeap:Boolean=False):TDateTime;
var
i,j:integer;
DayCount:integer;
wBigSmallDist,wLeap,wLeapShift:WORD;
begin
// 0101 010010101111 高四位是闰月位置,后12位表示大小月,大月30天,小月29天,
DayCount := 0;
if (cnYear < 1990) or (cnYear >2050) then begin
Result := 0;
Exit;
end;
for i:= cstCNYearOrg to cnYear-1 do begin
wBigSmallDist := cstCNTable;
if (wBIgSmallDist and $F000) <> 0 then DayCount := DayCount + 29;
DayCount := DayCount + 12 * 29;
for j:= 1 to 12 do begin
DayCount := DayCount + wBigSmallDist and 1;
wBigSmallDist := wBigSmallDist shr 1;
end;
end;
wBigSmallDist := cstCNTable[cnYear];
wLeap := wBigSmallDist shr 12;
if wLeap > 12 then begin
wLeap := wLeap and 7;
wLeapShift := 1; //大月在闰月.
end else
wLeapShift := 0;
for j:= 1 to cnMonth-1 do begin
DayCount:=DayCount + (wBigSmallDist and 1) + 29;
if j=wLeap then DayCount := DayCount + 29;
wBigSmallDist := wBigSmallDist shr 1;
end;
if bLeap and (cnMonth = wLeap) then //是要闰月的吗?
DayCount := DayCount + 30 - wLeapShift;
result := cstDateOrg + DayCount + cnDay - 1;
end;

//将日期显示成农历字符串.
function GregDateToCNStr(dtGreg:TDateTime):String;
const hzNumber:array[0..10] of string=('零','一','二','三','四','五','六','七','八','九','十');
function ConvertYMD(Number:Word;YMD:Word):string;
var
wTmp:word;
begin
result := '';
if YMD = 1 then begin //年份
while Number > 0 do begin
result := hzNumber[Number Mod 10] + result;
Number := Number DIV 10;
end;
Exit;
end;
if Number<=10 then begin //可只用1位
if YMD = 2 then //月份
result := hzNumber[Number]
else //天
result := '初' + hzNumber[Number];
Exit;
end;
wTmp := Number Mod 10; //个位
if wTmp <> 0 then result := hzNumber[wTmp];
wTmp := Number Div 10; //十位
result:='十'+result;
if wTmp > 1 then result := hzNumber[wTmp] + result;
end;
var
cnYear,cnMonth,cnDay:word;
cnDate:TCNDate;
strLeap:string;
begin
cnDate:= DecodeGregToCNDate(dtGreg);
if cnDate = 0 then begin
result := '输入越界';
Exit;
end;
cnDay := cnDate and $1F;
cnMonth := (cnDate shr 5) and $F;
cnYear := (cnDate shr 9) and $FFF;
//测试第22位,为1表示闰月
if isCNLeap(cnDate) then strLeap:='(闰)' else strLeap := '';
result := '农历' + ConvertYMD(cnYear,1) + '年' + ConvertYMD(cnMonth,2) + '月'
+ strLeap + ConvertYMD(cnDay,3) ;
end;
end.

3h:
请将有节令的也帖上，马上给分。

最好有天干地支的

help!!!

嘻嘻，我以为这段程序有节令，原来没有，误会了。
其实节令这一节应该不难处理，不是有一一对应的关系吗？
参考一下有关农历等的书就可以嘛。

unit udemo;

interface

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

type
TForm1 = class(TForm)
VrCalendar1: TVrCalendar;
StyleComboBox: TComboBox;
Label1: TLabel;
Label2: TLabel;
Edit1: TEdit;
UpDown1: TUpDown;
Label3: TLabel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
ColorDialog: TColorDialog;
FontDialog: TFontDialog;
Button6: TButton;
Button7: TButton;
Button8: TButton;
Button9: TButton;
Button10: TButton;
Button11: TButton;
Button12: TButton;
Button13: TButton;
Label8: TLabel;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure StyleComboBoxChange(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure VrCalendar1Change(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure Button8Click(Sender: TObject);
procedure Button9Click(Sender: TObject);
procedure Button10Click(Sender: TObject);
procedure Button11Click(Sender: TObject);
procedure Button12Click(Sender: TObject);
procedure Button13Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
StyleComboBox.ItemIndex := 1;
VrCalendar1Change(self);
end;

procedure TForm1.StyleComboBoxChange(Sender: TObject);
begin
VrCalendar1.Style := TVrCalendarStyle(StyleComboBox.ItemIndex);
end;

procedure TForm1.Edit1Change(Sender: TObject);
var
N: Integer;
begin
N := StrToInt(Edit1.Text);
VrCalendar1.BorderWidth := N;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
VrCalendar1.PrevYear;
end;


procedure TForm1.Button2Click(Sender: TObject);
begin
VrCalendar1.NextYear;
end;


procedure TForm1.Button3Click(Sender: TObject);
begin
VrCalendar1.PrevMonth;
end;


procedure TForm1.Button4Click(Sender: TObject);
begin
VrCalendar1.NextMonth;
end;


procedure TForm1.Button5Click(Sender: TObject);
var
Y, M, D: Word;
begin
DecodeDate(Now, Y, M, D);
VrCalendar1.ChangeDate(Y, M, D);
end;

procedure TForm1.VrCalendar1Change(Sender: TObject);
begin
Label3.Caption :=
AnsiUpperCase(VrCalendar1.GetAsString(LongDateFormat));
Label5.Caption :=
IntToStr(VrCalendar1.WeekOfTheYear);
Label7.Caption :=
IntToStr(VrCalendar1.DayOfTheYear);
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
if ColorDialog.Execute then
VrCalendar1.Color := ColorDialog.Color;
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
if ColorDialog.Execute then
VrCalendar1.DaysColor := ColorDialog.Color;
end;

procedure TForm1.Button8Click(Sender: TObject);
begin
if ColorDialog.Execute then
VrCalendar1.GridColor := ColorDialog.Color;
end;

procedure TForm1.Button9Click(Sender: TObject);
begin
if ColorDialog.Execute then
VrCalendar1.FocusColor := ColorDialog.Color;
end;

procedure TForm1.Button10Click(Sender: TObject);
begin
if ColorDialog.Execute then
VrCalendar1.PassiveColor := ColorDialog.Color;
end;


procedure TForm1.Button11Click(Sender: TObject);
begin
FontDialog.Font := VrCalendar1.Font;
if FontDialog.Execute then
VrCalendar1.Font := FontDialog.Font;
end;

procedure TForm1.Button12Click(Sender: TObject);
begin
FontDialog.Font := VrCalendar1.DaysFont;
if FontDialog.Execute then
VrCalendar1.DaysFont := FontDialog.Font;
end;


procedure TForm1.Button13Click(Sender: TObject);
begin
VrCalendar1.DaysVisible := not VrCalendar1.DaysVisible;
end;


procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label8.Visible := not Label8.Visible;
end;

end.
//****************************************************************
// VARIAN CALENDAR CONTROL v2.0 beta
// (c) VARIAN SOFTWARE SERVICES NL 1996-1997
//****************************************************************

//Written by Varian Software Services NL, The Netherlands
//Subject: Calendar Control Component
//Version: 2.0 Beta
//Platform: Delphi 3, Win95, NT
//Date: 18 May 1997
//Last update: 26 July 1997
//Release: Freeware, just let us know what you think of it....

//if you make any modifications to the source, please send us a copy.
//We will verify your changes and give you proper credit when included.

//Please send any questions, remarks or suggestions to our following
//address: Varian@worldaccess.nl

//Latest updates:

//Renamed the component to TVrCalendar...

//Changed a lot of the internal structure and the published settings of
//the control. The Calendar has now much more configuration settings.
//All the public methods are kept the same for compatibility with
//older versions.

//Note:
//When turning the daynames on/off, the control becomes sometimes
//smaller in height. This is not a bug, just een divide problem
//when calculating the new row count.

unit vrcal;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, DB, DBCtrls;

type
TVrCalendarStyle = (csRaised, csLowered, csNone);

TVrCalendar = class;

TVrCalendarItem = class(TObject)
private
FOwner: TVrCalendar;
FId: Integer;
FContents: string;
public
constructor Create(Owner: TVrCalendar; Id: Integer);
destructor Destroy; override;
procedure Update;
property Contents: String read FContents write FContents;
end;

TVrCalendar = class(TCustomControl)
private
FItems: TList;
FColumns: Integer;
FRows: Integer;
FCellXSize: Integer;
FCellYSize: Integer;
FStyle: TVrCalendarStyle;
FGridColor: TColor;
FBorderWidth: Integer;
FYear, FMonth, FDay: Word;
FCurrent: Integer;
FMonthOffset: Integer;
FDaysVisible: Boolean;
FDaysFont: TFont;
FDaysColor: TColor;
FFocusColor: TColor;
FPassiveColor: TColor;
FReadOnly: Boolean;
FButton: TMouseButton;
FButtonDown: Boolean;
FHasFocus: Boolean;
FOnChange: TNotifyEvent;
function GetCount: Integer;
function GetItem(Index: Integer): TVrCalendarItem;
function GetCellFromPos(X, Y: Integer): Integer;
function GetFirstCell: Integer;
function GetLastCell: Integer;
procedure GetCellRect(Wich: Integer; var R: TRect);
procedure SetStyle(Value: TVrCalendarStyle);
procedure SetGridColor(Value: TColor);
procedure SetBorderWidth(Value: Integer);
procedure SetDaysVisible(Value: Boolean);
procedure SetDaysFont(Value: TFont);
procedure SetDaysColor(Value: TColor);
procedure SetFocusColor(Value: TColor);
procedure SetPassiveColor(Value: TColor);
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
protected
procedure Clear;
procedure BuildStruct;
procedure AnalyseMonth;
procedure CalcPaintParams(DoRepaint: Boolean);
procedure DrawCell(Wich: Integer; Contents: string);
function IsDayName(I: Integer): Boolean;
procedure FocusCell(Wich: Integer);
procedure UpdateCells;
procedure Change; dynamic;
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
property Count: Integer read GetCount;
property Items[Index: Integer]: TVrCalendarItem read GetItem;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function DaysThisMonth: Integer;
function DayofTheYear: Integer;
function WeekOfTheYear: Integer;
function ChangeDate(AYear, AMonth, ADay: Word): Boolean;
function GetAsDateTime: TDateTime;
function GetAsString(Format: String): String;
procedure NextYear;
procedure PrevYear;
procedure NextMonth;
procedure PrevMonth;
property Day: Word read FDay;
property Month: Word read FMonth;
property Year: Word read FYear;
published
property Style: TVrCalendarStyle read FStyle write SetStyle;
property GridColor: TColor read FGridColor write SetGridColor;
property BorderWidth: Integer read FBorderWidth write SetBorderWidth;
property DaysVisible: boolean read FDaysVisible write SetDaysVisible;
property DaysFont: TFont read FDaysFont write SetDaysFont;
property DaysColor: TColor read FDaysColor write SetDaysColor;
property FocusColor: TColor read FFocusColor write SetFocusColor;
property PassiveColor: TColor read FPassiveColor write SetPassiveColor;
property ReadOnly: Boolean read FReadOnly write FReadOnly;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property Align;
property Color;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopUpMenu;
property ShowHint;
property TabOrder;
property TabStop default true;
property Visible;
property OnClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

TDBVrCalendar = class(TVrCalendar)
FDataLink: TFieldDataLink;
private
procedure DataChange(Sender: TObject);
procedure UpdateData(Sender: TObject);
function GetDataField: string;
function GetDataSource: TDataSource;
procedure SetDataField(const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure CMExit(var Message: TCMExit); message CM_EXIT;
protected
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure Change; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
end;

procedure Register;

implementation

const
CalendarRows: array[boolean] of integer = (6, 7);

procedure Register;
begin
RegisterComponents('Varian Freeware', [TVrCalendar, TDBVrCalendar]);
end;

{$I VRCAL.INC}

//TVrCalendarItem

constructor TVrCalendarItem.Create(Owner: TVrCalendar; Id: Integer);
begin
if (Owner <> nil) then
begin
Owner.FItems.add(self);
FOwner := Owner;
end;
FId := Id;
FContents := '';
end;

destructor TVrCalendarItem.Destroy;
begin
if FOwner <> nil then
FOwner.FItems.Remove(self);
Inherited Destroy;
end;

procedure TVrCalendarItem.Update;
begin
if FOwner <> nil then
FOwner.DrawCell(FId, FContents);
end;


//TVrCalendar

constructor TVrCalendar.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
ControlStyle := ControlStyle + [csOpaque];
Width := 150;
Height := 100;
ParentColor := false;
Color := clBtnFace;
TabStop := true;
FGridColor := clBlack;
FStyle := csLowered;
FBorderWidth := 1;
FColumns := 7;
FRows := 7;
FDaysVisible := true;
FDaysFont := TFont.Create;
FDaysColor := Color;
FFocusColor := clHighlight;
FPassiveColor := FFocusColor;
FReadOnly := false;
DecodeDate(Now, FYear, FMonth, FDay);
FItems := TList.Create;
BuildStruct;
AnalyseMonth;
end;

destructor TVrCalendar.Destroy;
begin
if FItems <> nil then Clear;
FItems.Free;
FDaysFont.Free;
Inherited Destroy;
end;

procedure TVrCalendar.BuildStruct;
var
I, N: Integer;
begin
Clear;
N := FColumns * FRows;
for I := 0 to Pred(N) do
TVrCalendarItem.Create(self, I);
end;

procedure TVrCalendar.AnalyseMonth;
var
I: Integer;
DayNum: Integer;
begin
FMonthOffset := 1 - GetDayOfWeek(FYear, FMonth, 1);
if FDaysVisible then Dec(FMonthOffset, FColumns);
FCurrent := -FMonthOffset + FDay;
for I := 0 to Pred(Count) do
begin
DayNum := FMonthOffset + I;
if (I < FColumns) and (FDaysVisible) then
Items.Contents := ShortDayNames[I + 1]
else
if (DayNum < 1) or (DayNum > DaysThisMonth) then
Items.Contents := ''
else
Items.Contents := IntToStr(DayNum);
end;
end;

procedure TVrCalendar.Clear;
begin
while FItems.Count > 0 do TVrCalendarItem(FItems.Last).Free;
end;

function TVrCalendar.GetCount: Integer;
begin
Result := FItems.Count;
end;

function TVrCalendar.GetItem(Index: Integer): TVrCalendarItem;
begin
Result := FItems[Index];
end;

procedure TVrCalendar.SetStyle(Value: TVrCalendarStyle);
begin
if (FStyle <> Value) then
begin
FStyle := Value;
Invalidate;
end;
end;

procedure TVrCalendar.SetGridColor(Value: TColor);
begin
if (FGridColor <> Value) then
begin
FGridColor := Value;
Invalidate;
end;
end;

procedure TVrCalendar.SetBorderWidth(Value: Integer);
begin
if (FBorderWidth <> Value) and (Value in [0..5]) then
begin
FBorderWidth := Value;
Invalidate;
end;
end;

procedure TVrCalendar.SetDaysVisible(Value: Boolean);
begin
if (FDaysVisible <> Value) then
begin
FDaysVisible := Value;
FRows := CalendarRows[Value];
BuildStruct;
AnalyseMonth;
CalcPaintParams(true);
end;
end;

procedure TVrCalendar.SetDaysFont(Value: TFont);
begin
FDaysFont.Assign(Value);
Invalidate;
end;

procedure TVrCalendar.SetDaysColor(Value: TColor);
begin
if (FDaysColor <> Value) then
begin
FDaysColor := Value;
Invalidate;
end;
end;

procedure TVrCalendar.SetFocusColor(Value: TColor);
begin
if (FFocusColor <> Value) then
begin
FFocusColor := Value;
Items[FCurrent].Update;
end;
end;

procedure TVrCalendar.SetPassiveColor(Value: TColor);
begin
if (FPassiveColor <> Value) then
begin
FPassiveColor := Value;
Items[FCurrent].Update;
end;
end;

procedure TVrCalendar.DrawCell(Wich: Integer; Contents: string);
var
R: TRect;
begin
GetCellRect(Wich, R);
case FStyle of
csLowered: Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, FBorderWidth);
csRaised: Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, FBorderWidth);
csNone:
begin
//Make sure the lines don't overlap
if not (Wich in [6, 13, 20, 27, 34, 41, 48]) then
Inc(R.Right);
if Wich < Count - FColumns then
Inc(R.Bottom);
Frame3D(Canvas, R, FGridColor, FGridColor, FBorderWidth);
end;
end;

with Inherited Canvas do
begin
if (Wich = FCurrent) then
begin
Font := Self.Font;
if FHasFocus then
Brush.Color := FFocusColor
else
Brush.Color := FPassiveColor;
end
else
case IsDayName(Wich) of
true:
begin
Font := FDaysFont;
Brush.Color := FDaysColor;
end;
false:
begin
Font := Self.Font;
Brush.Color := Self.Color;
end;
end; //Case
Brush.Style := bsSolid;
FillRect(R);
DrawText(Handle, PChar(Contents), -1, R,
DT_SINGLELINE or DT_EXPANDTABS or DT_CENTER or DT_VCENTER);
if (FHasFocus) and (Wich = FCurrent) then
DrawFocusRect(R);
end;
end;

procedure TVrCalendar.Paint;
var
I: Integer;
begin
with Inherited Canvas do
begin
Brush.Color := Color;
Brush.Style := bsSolid;
FillRect(ClientRect);
end;
for I := 0 to Pred(Count) do
Items.Update;
end;

procedure TVrCalendar.CalcPaintParams(DoRepaint: Boolean);
var
NewWidth, NewHeight: Integer;
begin
NewWidth := (Width div FColumns) * FColumns;
NewHeight := (Height div FRows) * FRows;
BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);
FCellXSize := Width div FColumns;
FCellYSize := Height div FRows;
if DoRepaint then Invalidate;
end;

procedure TVrCalendar.WMSize(var Message: TWMSize);
begin
inherited;
CalcPaintParams(false);
end;

procedure TVrCalendar.GetCellRect(Wich: Integer; var R: TRect);
var
X, Y: Integer;
begin
X := (Wich mod FColumns) * FCellXSize;
Y := (Wich div FColumns) * FCellYSize;
R := Bounds(X, Y, FCellXSize, FCellYSize);
end;

function TVrCalendar.GetCellFromPos(X, Y: Integer): Integer;
var
W, H: Integer;
begin
W := (FCellXSize * FColumns) - 1;
H := (FCellYSize * FRows) - 1;
if X > W then X := W else if X < 0 then X := 0;
if Y > H then Y := H else if Y < 0 then Y := 0;
X := (Y div FCellYSize) * FColumns + (X div FCellXSize);
Result := X;
end;

function TVrCalendar.IsDayName(I: Integer): Boolean;
begin
Result := (I < FColumns) and (FDaysVisible);
end;

function TVrCalendar.DaysThisMonth: Integer;
begin
Result := DaysPerMonth(FYear, FMonth);
end;

function TVrCalendar.GetFirstCell: Integer;
begin
Result := -FMonthOffset + 1;
end;

function TVrCalendar.GetLastCell: Integer;
begin
Result := -FMonthOffset + DaysThisMonth;
end;

procedure TVrCalendar.WMSetFocus(var Message: TWMSetFocus);
begin
FHasFocus := True;
Items[FCurrent].Update;
inherited;
end;

procedure TVrCalendar.WMKillFocus(var Message: TWMKillFocus);
begin
FHasFocus := False;
Items[FCurrent].Update;
inherited;
end;

procedure TVrCalendar.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS;
end;

procedure TVrCalendar.FocusCell(Wich: Integer);
var
OldCell: Integer;
begin
if (Wich = FCurrent) or (Wich < GetFirstCell) or
(Wich > GetLastCell) or (FReadOnly) then Exit;
OldCell := FCurrent;
FCurrent := Wich;
FDay := StrToInt(Items[FCurrent].Contents);
Items[OldCell].Update;
Items[FCurrent].Update;
Change;
end;

procedure TVrCalendar.Change;
begin
if assigned(FOnChange) then
FOnChange(self);
end;

procedure TVrCalendar.UpdateCells;
var
I: Integer;
begin
AnalyseMonth;
for I := 0 to Pred(Count) do
if not IsDayName(I) then Items.Update;
end;

procedure TVrCalendar.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
FButton := Button;
FButtonDown := true;
if Button = mbLeft then
FocusCell(GetCellFromPos(X, Y));
if TabStop then SetFocus;
end;

procedure TVrCalendar.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
if (FButtonDown) and (FButton = mbLeft) then
FocusCell(GetCellFromPos(X, Y));
end;

procedure TVrCalendar.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
FButtonDown := False;
end;

procedure TVrCalendar.KeyDown(var Key: Word; Shift: TShiftState);
var
NewSel: Integer;
begin
inherited KeyDown(Key, Shift);
NewSel := FCurrent;
case Key of
VK_HOME: NewSel := GetFirstCell;
VK_END: NewSel := GetLastCell;
VK_UP: if NewSel - FColumns >= GetFirstCell then Dec(NewSel, FColumns);
VK_LEFT: if NewSel > GetFirstCell then Dec(NewSel);
VK_DOWN: if (NewSel + FColumns <= GetLastCell) then Inc(NewSel, FColumns);
VK_RIGHT: if NewSel < GetLastCell then Inc(NewSel);
end;
Key := 0;
FocusCell(NewSel);
end;

function TVrCalendar.ChangeDate(AYear, AMonth, ADay: Word): Boolean;
begin
Result := IsValiddate(AYear, AMonth, ADay);
if Result then
begin
FDay := ADay;
FMonth := AMonth;
FYear := AYear;
UpdateCells;
Change;
end;
end;

function TVrCalendar.GetAsDateTime: TDateTime;
begin
Result := EncodeDate(FYear, FMonth, FDay);
end;

function TVrCalendar.GetAsString(Format: String): String;
begin
Result := FormatDateTime(Format, GetAsDateTime);
end;

procedure TVrCalendar.NextYear;
begin
if IsLeapYear(FYear) and (FMonth = 2) and (FDay = 29) then FDay := 28;
FYear := FYear + 1;
UpdateCells;
Change;
end;

procedure TVrCalendar.PrevYear;
begin
if IsLeapYear(FYear) and (FMonth = 2) and (FDay = 29) then FDay := 28;
FYear := FYear - 1;
UpdateCells;
Change;
end;

procedure TVrCalendar.NextMonth;
begin
if (FMonth < 12) then Inc(FMonth)
else
begin
FMonth := 1;
FYear := FYear + 1;
end;
if FDay > DaysThisMonth then FDay := DaysThisMonth;
UpdateCells;
Change;
end;

procedure TVrCalendar.PrevMonth;
begin
if (FMonth > 1) then Dec(FMonth)
else
begin
FMonth := 12;
FYear := FYear - 1;
end;
if FDay > DaysThisMonth then FDay := DaysThisMonth;
UpdateCells;
Change;
end;

function TVrCalendar.DayOfTheYear: Integer;
var
yy, mm, dd, Tmp: Integer;
begin
yy := FYear;
mm := FMonth;
dd := FDay;
Tmp := (mm + 10) div 13;
Result := 3055 * (mm + 2) div 100 - Tmp * 2 - 91 +
(1 - (yy - yy div 4 * 4 + 3) div 4 +
(yy - yy div 100 * 100 + 99) div 100 -
(yy - yy div 400 * 400 + 399) div 400) * Tmp + dd;
end;

function TVrCalendar.WeekOfTheYear: Integer;
begin
Result := WeekOfYear(FYear, FMonth, FDay);
if Result = 0 then
Result := WeekOfYear(FYear - 1, 12, 31); {belongs to previous year}
end;

//TDBVrCalendar
constructor TDBVrCalendar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
FDataLink.OnUpdateData := UpdateData;
end;

destructor TDBVrCalendar.Destroy;
begin
FDataLink.Free;
inherited Destroy;
end;

procedure TDBVrCalendar.DataChange(Sender: TObject);
var
Y, M, D: Word;
begin
if assigned(FDataLink.Field) then
begin
DecodeDate(FDataLink.Field.AsDateTime, Y, M, D);
ChangeDate(Y, M, D);
end;
end;

function TDBVrCalendar.GetDataField: string;
begin
Result := FDataLink.FieldName;
end;

function TDBVrCalendar.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;

procedure TDBVrCalendar.SetDataField(const Value: string);
begin
FDataLink.FieldName := Value;
end;

procedure TDBVrCalendar.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
end;

procedure TDBVrCalendar.UpdateData(Sender: TObject);
begin
FDataLink.Field.AsDateTime := GetAsDateTime;
end;

procedure TDBVrCalendar.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
MyMouseDown: TMouseEvent;
begin
if not ReadOnly and FDataLink.Edit then
inherited MouseDown(Button, Shift, X, Y)
else
begin
MyMouseDown := OnMouseDown;
if Assigned(MyMouseDown) then MyMouseDown(Self, Button, Shift, X, Y);
end;
end;

procedure TDBVrCalendar.KeyDown(var Key: Word; Shift: TShiftState);
var
MyKeyDown: TKeyEvent;
begin
if (not ReadOnly) and (FDataLink.Edit) then
inherited KeyDown(Key, Shift)
else
begin
MyKeyDown := OnKeyDown;
if Assigned(MyKeyDown) then MyKeyDown(Self, Key, Shift);
end;
end;

procedure TDBVrCalendar.Change;
begin
FDataLink.Modified;
inherited Change;
end;

procedure TDBVrCalendar.CMExit(var Message: TCMExit);
begin
try
FDataLink.UpdateRecord;
except
SetFocus;
raise;
end;
inherited;
end;

end.

够长的代码。：）
看来只结果了，时间太久了。

---- by 3h 99.9.4 12:04