在Delphi中定位组件的提示

Question

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 eg via OnShowHint - it has to be specific to these controls)

Answer 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.