delphi - Delphi 中组件的定位提示

Question

使用 Delphi XE6，我正在创建一个类似 TdateTimePicker 的控件，但由于几个原因，我使用了 TButtonedEdit，其中“嵌入”了 TMonthCalendar。完整的简单演示是:

我已经按照预期进行了，当单击右键(使用 Style=WS_POPUP)时显示月历，并在做出选择时隐藏它，用户导航离开，转义符等。

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.

现在，我想为编辑框和 TMonthCalendar 添加单独的提示，但我想确保显示的提示不会遮挡相关控件。对于编辑框，我已经成功拦截了 CM_HINTSHOW 消息，并设置了 HintInfo.HintPos 来实现这一点。到目前为止，一切顺利。

问题 1:更新:我现在已经显示了。最初，我将提示文本设置为包含管道字符，以便我可以使用 TCustomHint。删除管道字符，导致显示提示。 但是此提示不会隐藏自身，它会在 TmonthCalendar 显示时保留在屏幕上。我怎样才能让它“ self 隐藏”？

问题 2:如果我对任一控件使用 TCustomHint，则 CMHintShow 过程永远不会触发。那么，如果我确实想使用 TCustomHint 来实现它提供的额外控制，那么这会如何改变定位策略呢？(我不希望在“应用程序”级别进行任何操作，例如通过 OnShowHint - 它必须特定于这些控件)

Answer 1

正如问题评论中所确定的那样，提示不会无限期地保留在屏幕上，但实际上一旦隐藏就会不断重新显示。

原因是，VCL 假定提示控件是子窗口，这是因为它的 Parent 属性不为零。就问题中的代码而言，尽管月历通过将其转变为弹出窗口而 float ，但就 VCL 所知，其父级仍然是表单。这会导致应用程序的ActivateHint过程中提示矩形的计算出错。另一方面，应用程序的 HintMouseMessage 过程并不关心控件是否为父控件。接下来发生的情况是，虽然您没有在控件上移动鼠标指针，但 VCL 会推断鼠标指针不断离开提示边界然后重新进入。

这是该问题的简化再现:

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.

在上面的代码中，按钮的提示会在超时时隐藏，而面板的提示在隐藏后会重新显示。我特意将窗口定位到它们的位置，以便您可以在激活提示时观察指针位置的意义。如果您将鼠标指针从下方输入面板，提示将仅显示一次，然后隐藏。但是，如果您从上面进入面板，您就会看到问题。

修复方法很简单，您可以修改 CM_HINTSHOW 消息处理程序中的提示矩形。由于控制是 float 的，因此不需要复杂的计算。相应地修改了复制案例，这也修复了问题中的日历:

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;

---

对于问题 2，不幸的是，自定义提示窗口似乎没有被设计为可定位的。提示窗口是本地创建的，没有巧妙的方法来获取它或以任何其他方式指定其位置。我能想到的唯一方法是重写自定义提示的绘制方法之一，该方法将提示窗口公开为参数。因此，我们可以在提示窗口收到绘画消息后立即重新定位它。

这是一个工作示例(对于普通(非 float )控件):

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.