问题
Using Delphi XE6, I am creating a TdateTimePicker-like control, but for a couple of reasons, I am using a TButtonedEdit which has a TMonthCalendar "embedded" within it. A full bare-bones demo is:
I have got it going as desired with the month calendar being SHOWn when the right button is clicked (with Style=WS_POPUP) and I HIDE it when a selection is made, the user navigates away, ESCapes etc.
unit DateEditBare1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.ImgList, Vcl.ComCtrls, Vcl.StdCtrls,
CommCtrl;
type
TespMonthCalendar = class(TMonthCalendar)
procedure DoCloseUp(Sender: TObject);
private
FDroppedDown: boolean;
FManagerHandle: HWND; // just a convenience to avoid having to assume its in the owner
procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
procedure SetWindowDIMs;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
end;
TespDateEdit = class(TButtonedEdit)
private
FMonthCalendar: TespMonthCalendar;
procedure DoRightButtonClick(Sender: TObject);
protected
procedure CreateWnd; override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
public
constructor Create(AOwner:TComponent); override;
property MonthCalendar: TespMonthCalendar read FMonthCalendar write FMonthCalendar;
end;
TfrmDateEditBare1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
private
espDateEdit1: TespDateEdit;
public
end;
var
frmDateEditBare1: TfrmDateEditBare1;
implementation
{$R *.dfm}
var
_espdateEdit_ImageList: TImageList=nil;
//------------------------------------------------------------------------------
function MakeImageList(const ResNames: array of String): TImageList;
var
ResBmp: TBitmap;
I: Integer;
begin
{ Create an image list. }
_espdateEdit_ImageList := TImageList.Create(nil);
_espdateEdit_ImageList.Width := 24;
_espdateEdit_ImageList.Height := 16;
Result := _espdateEdit_ImageList;
for I := 0 to Length(ResNames) - 1 do
begin
ResBmp := TBitmap.Create();
try
{ Try to load the bitmap from the resource. }
try
//ResBmp.LoadFromResourceName(HInstance, ResNames[I]);
ResBmp.SetSize(24,16);
ResBmp.Transparent := true;
except
ResBmp.Free();
Result.Free();
Exit;
end;
Result.Add(ResBmp, nil);
finally
ResBmp.Free;
end;
end;
end;
// Aowner is ignored for now
function GetImageList: TImageList;
begin
if _espdateEdit_ImageList = nil then
result := MakeImageList(['CalendarDrop', 'CalendarDropShifted'])
else
result := _espdateEdit_ImageList;
end;
//------------------------------------------------------------------------------
procedure TfrmDateEditBare1.FormCreate(Sender: TObject);
begin
espDateEdit1:= TespDateEdit.Create(self);
espDateEdit1.Parent := self;
espDateEdit1.left := 100;
espDateEdit1.top := 100;
espDateEdit1.Visible := true;
end;
//------------------------------------------------------------------------------
{ TespMonthCalendar }
procedure TespMonthCalendar.CMHintShow(var Message: TCMHintShow);
begin
inherited;
if Message.HintInfo.HintControl=Self then
begin
Message.HintInfo.HintPos := self.ClientToScreen(Point(0, self.Height + 1));
Message.HintInfo.HideTimeout := 1000;
// Message.HintInfo.ReshowTimeout := 1500; // setting this does not help
end;
end;
procedure TespMonthCalendar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
Style := WS_POPUP;
WindowClass.Style := WindowClass.Style or CS_SAVEBITS ;
if CheckWin32Version(5, 1) then
WindowClass.Style := WindowClass.style or CS_DROPSHADOW;
end;
end;
procedure TespMonthCalendar.CreateWnd;
begin
inherited;
// Get/set the dimensions of the calendar
SetWindowDIMs;
end;
procedure TespMonthCalendar.SetWindowDIMs;
var
ReqRect: TRect;
MaxTodayWidth: Integer;
begin
FillChar(ReqRect, SizeOf(TRect), 0);
// get required rect
Win32Check(MonthCal_GetMinReqRect(Handle, ReqRect));
// get max today string width
MaxTodayWidth := MonthCal_GetMaxTodayWidth(Handle);
// adjust rect width to fit today string
if MaxTodayWidth > ReqRect.Right then
ReqRect.Right := MaxTodayWidth;
// set new height & width
Width := ReqRect.Right ;
Height:= ReqRect.Bottom ;
end; (* SetWindowDIMs *)
procedure TespMonthCalendar.CNNotify(var Message: TWMNotify);
begin
// hand off control of the selection to the boss i.e. the espDateEdit that I belong to
// skip for demo ... just closeup
if ( Message.NMHdr^.code = MCN_SELECT) then
DoCloseUp(self);
inherited;
end; (*CNNotify*)
procedure TespMonthCalendar.KeyDown(var Key: Word; Shift: TShiftState);
begin
if Key = VK_ESCAPE then
begin
Key := 0;
DoCloseUp(self);
end
else
inherited KeyDown(Key, Shift);
end;
procedure TespMonthCalendar.WMActivate(var Msg: TWMActivate);
begin
if (Msg.Active <> WA_INACTIVE) then
// tell form to paint itself as though it still has focus (as we are no outside the form with POPUP)
SendMessage(screen.ActiveForm.Handle, WM_NCACTIVATE, WPARAM(True), -1)
else
DoCloseUp(self);
inherited;
end;
procedure TespMonthCalendar.DoCloseUp(Sender: TObject);
begin
if FDroppedDown then
begin
FDroppedDown := false;
Hide;
// put focus back on dateedit so that checking is done if we leave here to go on to another control
SendMessage(FManagerHandle, WM_ACTIVATE, WPARAM(True), -1); // less assumptions this way
end;
end;
//------------------------------------------------------------------------------
{ TespDateEdit }
procedure TespDateEdit.CMHintShow(var Message: TCMHintShow);
begin
inherited;
if Message.HintInfo.HintControl=Self then
Message.HintInfo.HintPos := self.ClientToScreen(Point(0, 21));
end;
constructor TespDateEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if not(csDesigning in ComponentState) then
begin
FmonthCalendar := TespMonthCalendar.Create(self);
self.hint := 'DUMMY HINT for Edit Box';
FMonthCalendar.Hint := 'Select required Date,' + ^M^J + 'or ESCape to close the calendar.';
FMonthCalendar.ShowHint := true;
end;
Width := 100;
Height := 21;
Images := GetImageList;
Text := ''; // FormatdateTime('dd/mm/yy', Date); // not for demo
ShowHint := True;
DoubleBuffered := true; // reduces flicker when passing thru and within control
RightButton.ImageIndex := 0;
RightButton.PressedImageIndex := 1;
RightButton.Visible := True;
OnRightButtonClick := DoRightButtonClick;
end;
procedure TespDateEdit.CreateWnd;
var
P: TWinControl;
begin
inherited CreateWnd;
if not(csDesigning in ComponentState) then
begin
FMonthCalendar.left := -900;
P := self.Parent;
while (P <> nil ) and not ( P is TCustomForm ) do
P := P.parent;
FmonthCalendar.Parent := P; // ie form (or the topmost non nil entry in the tree)
FmonthCalendar.FManagerHandle := self.Handle;
FMonthCalendar.Hide;
FmonthCalendar.OnExit := FmonthCalendar.DoCloseUp;
end;
end;
procedure TespDateEdit.DoRightButtonClick(Sender: TObject);
var
dt: Tdate;
TopLeft: TPoint;
Rect: TRect;
begin
if FmonthCalendar.FdroppedDown then
begin
FMonthCalendar.DoCloseUp(nil);
exit;
end;
// load non-zero date into calendar as the selected date ... skip for demo
TopLeft := self.ClientToScreen(Point(0, 0)); // i.e. screen co-ords of top left of edit box
monthCalendar.left := TopLeft.X - 3 ; // shift a poopsie to line up visually
monthCalendar.Top := TopLeft.Y + self.Height - 2;
// only move it if it exceeds screen bounds ... skip this for demo
FmonthCalendar.FDroppedDown := true;
MonthCal_SetCurrentView(FmonthCalendar.handle, MCMV_MONTH);
FmonthCalendar.Show;
// showing is not enough - need to grab focus to get kbd events happening on the calendar
FmonthCalendar.SetFocus;
inherited OnRightButtonClick;
end;
//------------------------------------------------------------------------------
initialization
finalization
FreeAndNil(_espdateEdit_ImageList);
end.
Now, I wanted to add separate hints for both the edit box and the TMonthCalendar, but I wanted to ensure that the displayed hint did not obscure the relevant control. For the edit box, I have successfully intercepted the CM_HINTSHOW message, and I set the HintInfo.HintPos to achieve that. So far, so good.
Question 1: Update: I have it showing now. Originally I had set the text of the hint to include the Pipe character so I could employ TCustomHint. Removing the pipe character, caused the hint to show. BUT this hint does not hide itself, it stays on screen whilst ever the TmonthCalendar is showing. How can I make it "self hide"?
Question 2: If I use a TCustomHint for either control, then the CMHintShow procedure never fires. So, if I did want to use a TCustomHint for the extra control it offers, how does that alter the positioning strategy? (And I don't wish to anything at the "application" level e.g. via OnShowHint - it has to be specific to these controls)
回答1:
As have been established in the comments to the question, the hint does not stay on the screen indefinitely but it is actually continuously re-shown as soon as it is hidden.
The reason for that is, the VCL assumes the hint control to be a child window, that's because it's Parent property is not nil. In the case of the code in the question, although the month calendar floats by mutating it to be a popup window, its parent is still the form as far as the VCL knows it. This causes the calculation for the hint rectangle in ActivateHint procedure of the Application to go wrong. On the other hand, HintMouseMessage procedure of the Application does not care if the control is parented or not. What happens then is, although you don't move the mouse pointer on the control, VCL infers the mouse pointer continuously leaves the hint boundary and then re-enters.
Here is a simplified reproduction for the problem:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;
type
TPanel = class(vcl.extctrls.TPanel)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TPanel }
procedure TPanel.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := WS_POPUPWINDOW or WS_THICKFRAME;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.Hint := 'Button1';
Panel1.Hint := 'Panel1';
ShowHint := True;
Application.HintHidePause := 1000;
Left := 0;
Top := 0;
Panel1.ParentBackground := False;
Panel1.Left := 0;
Panel1.Height := 50;
Panel1.Top := Top + Height;
end;
end.
In the above code, the button's hint will hide when it times out, on the other hand the panel's hint is re-shown after it is hidden. I located the windows deliberately to their positions so that you can observe the significance of the position of the pointer when the hint is activated. If you enter the mouse pointer to the panel from the below, the hint will show only once and then hide. If you enter the panel from above however, you'll see the problem.
The fix is simple, you can modify the hint rectangle in a CM_HINTSHOW message handler. Since the control is floating, no complex calculation is required. Accordingly modified reproduction case, which also fixes the calendar in the question:
type
TPanel = class(vcl.extctrls.TPanel)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
end;
TForm1 = class(TForm)
...
{ TPanel }
procedure TPanel.CMHintShow(var Message: TCMHintShow);
begin
inherited;
if (GetAncestor(Handle, GA_ROOT) = Handle) and Assigned(Parent) then
Message.HintInfo.CursorRect := Rect(0, 0, Width, Height);
end;
As for question 2, a custom hint window unfortunately does not seem to be designed position-able. The hint window is created locally and there is no neat way to get a hold of it or to specify its position in any other way. The only way I could think of is to override one of the custom hint's paint methods which exposes the hint window as a parameter. So we can relocate the hint window as soon as it receives a paint message.
Here is a working example (for a normal (non-floating) control):
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TMyCustomHint = class(TCustomHint)
private
FControl: TControl;
public
procedure NCPaintHint(HintWindow: TCustomHintWindow; DC: HDC); override;
end;
procedure TMyCustomHint.NCPaintHint(HintWindow: TCustomHintWindow; DC: HDC);
var
Pt: TPoint;
begin
Pt := FControl.ClientToScreen(Point(0, 0));
SetWindowPos(HintWindow.Handle, 0, Pt.X, Pt.Y + FControl.Height, 0, 0,
SWP_NOSIZE or SWP_NOZORDER or SWP_NOACTIVATE);
inherited;
end;
//--------
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowHint := True;
Button1.Hint := 'button1 hint';
Button1.CustomHint := TMyCustomHint.Create(Self);
TMyCustomHint(Button1.CustomHint).FControl := Button1;
end;
end.
来源：https://stackoverflow.com/questions/41473016/positioning-hints-for-components-in-delphi