【delphi开源代码栏目提醒】:网学会员在delphi开源代码频道为大家收集整理了CLCAL.PAS提供大家参考,希望对大家有所帮助!
unit CLCAL;
interface
uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
Grids, SysUtils;
type
TDayOfWeek = 0..6;
TCLCal = class(TCustomGrid)
private
FDate: TDateTime;
FLunarYear: Integer;
FHintDate: THintWindow;
FMonthOffset: Integer;
FOnChange: TNotifyEvent;
FReadOnly: Boolean;
FStartOfWeek: TDayOfWeek;
FShowGregDate: Boolean;
FShowNavigator: Boolean;
FUpdating: Boolean;
FUseCurrentDate: Boolean;
function GetCellText(ACol, ARow: Integer): string;
function GetDateElement(Index: Integer): Integer;
function GetGregYear(GYear, LYear: Word; LMonth: SmallInt): Word;
procedure SetCalendarDate(Value: TDateTime);
procedure SetDateElement(Index: Integer; Value: Integer);
procedure SetShowNavigator(Value: Boolean);
procedure SetStartOfWeek(Value: TDayOfWeek);
procedure SetUseCurrentDate(Value: Boolean);
function StoreCalendarDate: Boolean;
protected
procedure Change; dynamic;
procedure ChangeMonth(Delta: Integer);
procedure Click; override;
function DaysPerLunarMonth(GYear, LYear, AMonth: Integer): Integer; virtual;
function LunarDaysThisMonth: Integer; virtual;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function SelectCell(ACol, ARow: Longint): Boolean; override;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WndProc(var Message: TMessage); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property CalendarDate: TDateTime read FDate write SetCalendarDate stored StoreCalendarDate;
property CellText[ACol, ARow: Integer]: string read GetCellText;
property LunarYear: Integer read FLunarYear;
procedure NextMonth;
procedure NextYear;
procedure PrevMonth;
procedure PrevYear;
procedure UpdateCalendar; virtual;
published
property Align;
property Anchors;
property BorderStyle;
property Color;
property Constraints;
property Ctl3D;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property GridLineWidth default 0;
property LunarDay: Integer index 3 read GetDateElement write SetDateElement stored False;
property LunarMonth: Integer index 2 read GetDateElement write SetDateElement stored False;
property GregYear: Integer index 1 read GetDateElement write SetDateElement stored False;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
property ShowHint;
property ShowGregDate: Boolean read FShowGregDate write FShowGregDate default True;
property ShowNavigator: Boolean read FShowNavigator write SetShowNavigator default True;
property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
property TabOrder;
property TabStop;
property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
property Visible;
property OnClick;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
uses CSPUtils, Dialogs, Consts, UN_UTL;
constructor TCLCal.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ defaults }
FUseCurrentDate := True;
FShowGregDate := True;
FShowNavigator := True;
FHintDate := THintWindow.Create(Self);
FixedCols := 0;
FixedRows := 2;
ColCount := 7;
RowCount := 8;
GridLineWidth := 0;
Height := 155;
Width := 335;
ScrollBars := ssNone;
Options := Options - [goRangeSelect] + [goDrawFocusSelected];
FDate := Date;
UpdateCalendar;
end;
destructor TCLCal.Destroy;
begin
FHintDate.Free;
Inherited;
end;
procedure TCLCal.WndProc(var Message: TMessage);
var
P: TPoint;
LunarRect: TRect;
begin
inherited;
if Assigned(FHintDate) and (Parent <> nil)
and Focused and FShowGregDate then
begin
if not GetCursorPos(P) then Exit;
LunarRect := ClientRect;
LunarRect.TopLeft := ClientToScreen(LunarRect.TopLeft);
LunarRect.BottomRight := ClientToScreen(LunarRect.BottomRight);
if (P.X < LunarRect.Left) or (P.X > LunarRect.Right) or
(P.Y > LunarRect.Bottom) then
FHintDate.ReleaseHandle;
end;
end;
procedure TCLCal.Change;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TCLCal.Click;
var
TheCellText: string;
begin
inherited Click;
TheCellText := CellText[Col, Row];
if TheCellText <> '' then LunarDay := StrToInt(TheCellText);
end;
function TCLCal.DaysPerLunarMonth(GYear, LYear, AMonth: Integer): Integer;
var
daterec: TDateRec;
begin
daterec.GregYear := GYear;
daterec.LunarYear := LYear;
daterec.wMonth := AMonth;
daterec.wDay := 0;
Result := DaysInLunarMonth(@daterec);
end;
function TCLCal.LunarDaysThisMonth: Integer;
var
daterec: TDateRec;
begin
daterec.GregYear := GetGregYear(GregYear, LunarYear, LunarMonth);
daterec.LunarYear := LunarYear;
daterec.wMonth := LunarMonth;
daterec.wDay := 0;
Result := DaysInLunarMonth(@daterec);
end;
procedure TCLCal.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var TheText: string;
// DayNum: Integer;
T_YEAR, T_MONTH, T_DAY : STRING;
DateRec: TDateRec;
TheCellText : STRING;
begin
IF ARow < 2 THEN
BEGIN
Canvas.FONT.Color := CLBLUE;
TheText := CellText[ACol, ARow];
with ARect, Canvas do
TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
END;
IF ARow >= 2 THEN
BEGIN
TheText := CellText[ACol, ARow];
Canvas.FONT.Color := CLGREEN;
with ARect, Canvas do
TextRect(ARect, Right - TextWidth(TheText) -((Right - Left) DIV 5),
Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
TheCellText := TheText;
if TheCellText <> '' then
begin
DateRec.GregYear := GetGregYear(GregYear, LunarYear, LunarMonth);
DateRec.LunarYear := LunarYear;
DateRec.wMonth := LunarMonth;
DateRec.wDay := StrToInt(TheCellText);
if not LunarToGregorianDate(@daterec) then Exit;
if daterec.GregYear > 1911 then
BEGIN
T_YEAR := IntToStr(daterec.GregYear - 1911);
T_MONTH := IntToStr(daterec.wMonth);
T_DAY := IntToStr(daterec.wDay);
END ELSE BEGIN
T_YEAR := IntToStr(daterec.GregYear);
T_MONTH := IntToStr(daterec.wMonth);
T_DAY := IntToStr(daterec.wDay);
END;
end;
Canvas.FONT.SIZE := FONT.SIZE -2;
Canvas.FONT.Color := CLRED;
with ARect, Canvas do TextOut(Left+((Right - Left
上一篇:
frmCKSetup1.frm
下一篇:
大学生汉语写作水平与英语水平相关性研究