unit TRM_DateTimePicker;
interface
uses
Windows,
Messages,
SysUtils,
Classes,
Controls,
Forms,
ComCtrls,
Dialogs,
ExtCtrls,
CommCtrl;
type
TTRM_DateTimePicker =
class(TDateTimePicker)
private
{ Private declarations }
FOnMouseLeave: TNotifyEvent;
FOnMouseEnter: TNotifyEvent;
FExtraSpaceX: Integer;
FExtraSpaceY: Integer;
procedure CMMouseEnter(
var msg: TMessage);
message CM_MOUSEENTER;
procedure CMMouseLeave(
var msg: TMessage);
message CM_MOUSELEAVE;
procedure CNNotify(
var Message: TWMNotify);
message CN_NOTIFY;
protected
{ Protected declarations }
procedure DoMouseEnter;
dynamic;
procedure DoMouseLeave;
dynamic;
procedure DoDropDown;
public
{ Public declarations }
Constructor Create(AOwner: tComponent);
Override;
procedure ShowMonthCalendar;
published
{ Published declarations }
property OnMouseEnter: TNotifyEvent
read FOnMouseEnter
write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent
read FOnMouseLeave
write FOnMouseLeave;
property WeekNumbers;
property WeekExtraSpaceX: Integer
Read FExtraSpaceX
write FExtraSpaceX;
property WeekExtraSpaceY: Integer
Read FExtraSpaceY
write FExtraSpaceY;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('
TRM', [TTRM_DateTimePicker]);
end;
{ TRM_DateTimePicker }
Constructor TTRM_DateTimePicker.Create(AOwner: tComponent);
begin
Inherited Create(AOwner);
FExtraSpaceX := 12;
FExtraSpaceY := 12;
WeekNumbers := True;
Self.Date := Now;
DateFormat := dfLong;
end;
procedure TTRM_DateTimePicker.ShowMonthCalendar;
begin
MonthCal_SetCurrentView(CalendarHandle, MCMV_YEAR);
end;
procedure TTRM_DateTimePicker.CMMouseEnter(
var msg: TMessage);
begin
DoMouseEnter;
end;
procedure TTRM_DateTimePicker.CMMouseLeave(
var msg: TMessage);
begin
DoMouseLeave;
end;
procedure TTRM_DateTimePicker.CNNotify(
var Message: TWMNotify);
begin
if Message.NMHdr.code = DTN_DROPDOWN
then
begin
if Self.WeekNumbers
then
DoDropDown;
end;
inherited;
end;
procedure TTRM_DateTimePicker.DoMouseEnter;
begin
if Assigned(FOnMouseEnter)
then
FOnMouseEnter(Self);
end;
procedure TTRM_DateTimePicker.DoMouseLeave;
begin
if Assigned(FOnMouseLeave)
then
FOnMouseLeave(Self);
end;
procedure TTRM_DateTimePicker.DoDropDown;
const
MCM_GETMAXTODAYWIDTH = MCM_FIRST + 21;
var
Style: LongInt;
hDTP: THandle;
r: TRect;
intTodayWidth: Integer;
cname:
array [0 .. 256]
of Char;
begin
inherited;
// to get a handle of calendar
hDTP := DateTime_GetMonthCal(Self.Handle);
// change a style
Style := GetWindowLong(hDTP, GWL_STYLE);
SetWindowLong(hDTP, GWL_STYLE, Style
or MCS_WEEKNUMBERS);
// now we must change the width for calendar because week numbers shifted all strings
// 1. to get the required rect
r := Rect(0, 0, 0, 0);
SendMessage(hDTP, MCM_GETMINREQRECT, 0, LongInt(@r));
// 2. to get the maximum width of the "today" string
intTodayWidth := SendMessage(hDTP, MCM_GETMAXTODAYWIDTH, 0, 0);
// 3. adjust rect width to fit the "today" string
if intTodayWidth > r.Right
then
r.Right := intTodayWidth;
// For Win7, the window (class=SysMonthCal32) is automatically inside
// a parent-window (class=DropDown). Check this. If so, take the parent window.
// If not so (class=TMainForm), take this window (for XP and lower)
GetClassName(GetParent(hDTP), cname, sizeof(cname));
if AnsiSameText(cname, '
DropDown')
then
begin
hDTP := GetParent(hDTP);
// To get it perfect (on my machines) is adding this code:
inc(r.Right, WeekExtraSpaceX);
inc(r.Bottom, WeekExtraSpaceY);
end;
// 4. to set new the height and width
MoveWindow(hDTP, r.Left, r.Top, r.Right - r.Left, r.Bottom - r.Top, True);
end;
end.