以模态形式创建时，Delphi 父窗口保持在其他窗口的顶部

Question

我创建了一个窗口，它应该突出显示表单上的控件。当父窗体位于另一个窗口后面时，此窗口不应该不位于其他应用程序窗口的顶部(尝试 Alt+Tab)。 除非红框是从模态表单创建的，否则这工作正常。

我想要实现的是，当从模式对话框创建并且切换到另一个应用程序时，红框不会停留在其他窗口的顶部。

我想省略 PopupParent 和 PopupMode，因为代码应该在 Delphi 7 - XE2 中工作(老实说，我尝试使用 PopupParent 但没有成功)。

框架未关闭的事实不是问题。

请检查下面的完整源代码(创建一个新的 VCL 应用程序并替换整个单元文本，不要在表单上放置任何组件)。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
  private
    procedure HighlightButton(Sender: TObject);
    procedure CreateModalDialog(Sender: TObject);
  protected
    procedure DoCreate; override;
  end;

  TOHighlightForm = class(TForm)
  private
    fxPopupParent: TCustomForm;
    procedure SetFormLook;
    procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  protected
    procedure Paint; override;
    procedure DoCreate; override;
    procedure Resize; override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    procedure ShowAt(const aPopupParent: TCustomForm; aRect: TRect; const aInflateRect: Integer = 0);
  end;


var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TOHighlightForm }

procedure TOHighlightForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  if HandleAllocated then
  with Params do begin
    if Assigned(fxPopupParent) then
      WndParent := fxPopupParent.Handle;
  end;
end;

procedure TOHighlightForm.DoCreate;
begin
  inherited;

  Color := clRed;

  FormStyle := fsStayOnTop;
  BorderStyle := bsNone;
  Position := poDesigned;
  DoubleBuffered := True;
end;

procedure TOHighlightForm.Paint;
begin
  with Canvas do begin
    Brush.Color := Self.Color;
    FillRect(Self.ClientRect);
  end;
end;

procedure TOHighlightForm.Resize;
begin
  inherited;

  SetFormLook;
  Repaint;
end;

procedure TOHighlightForm.SetFormLook;
var
  HR1, HR2: HRGN;
  xR: TRect;
begin
  if not HandleAllocated then
    exit;

  xR := Self.ClientRect;

  HR1 := CreateRectRgnIndirect(xR);
  InflateRect(xR, -3, -3);
  HR2 := CreateRectRgnIndirect(xR);

  if CombineRgn(HR1, HR1, HR2, RGN_XOR) <> ERROR then
    SetWindowRgn(Handle, HR1, True);
end;

procedure TOHighlightForm.ShowAt(const aPopupParent: TCustomForm; aRect: TRect;
  const aInflateRect: Integer);
begin
  if fxPopupParent <> aPopupParent then begin
    fxPopupParent := aPopupParent;
    RecreateWnd;
  end;

  if aInflateRect > 0 then
    InflateRect(aRect, aInflateRect, aInflateRect);

  SetBounds(aRect.Left, aRect.Top, aRect.Right-aRect.Left, aRect.Bottom-aRect.Top);

  Resize;

  ShowWindow(Handle, SW_SHOWNOACTIVATE);
  Visible := True;
end;

procedure TOHighlightForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
  Message.Result := MA_NOACTIVATE;
end;

procedure TOHighlightForm.WMNCHitTest(var Message: TWMNCHitTest);
begin
  Message.Result := HTTRANSPARENT;
end;

{ TForm1 }

procedure TForm1.CreateModalDialog(Sender: TObject);
var xModalForm: TForm;
begin
  xModalForm := TForm.CreateNew(Self);
  try
    with TButton.Create(Self) do begin
      Parent := xModalForm;
      Top := 70;
      Left := 10;
      Width := 200;
      OnClick := HighlightButton;
      Caption := 'This does not work (try Alt+Tab)';
    end;

    xModalForm.ShowModal;
  finally
    xModalForm.Free;
  end;
end;

procedure TForm1.DoCreate;
begin
  inherited;

  with TLabel.Create(Self) do begin
    Parent := Self;
    Left := 10;
    Top := 10;
    Caption :=
      'I create a window, that should highlight a control on a form.'#13#10+
      'This window should not stay on top of other application windows when'#13#10+
      'the parent form is behind another window (try Alt+Tab).'#13#10+
      'This works fine unless it is a modal form.';
  end;

  with TButton.Create(Self) do begin
    Parent := Self;
    Top := 70;
    Left := 10;
    Width := 200;
    OnClick := HighlightButton;
    Caption := 'This works fine';
  end;

  with TButton.Create(Self) do begin
    Parent := Self;
    Top := 100;
    Left := 10;
    Width := 200;
    OnClick := CreateModalDialog;
    Caption := 'Open modal window and try there';
  end;
end;

procedure TForm1.HighlightButton(Sender: TObject);
var
  xR: TRect;
  xControl: TControl;
begin
  xControl := TControl(Sender);
  xR.TopLeft := xControl.ClientToScreen(Point(0, 0));
  xR.BottomRight := Point(xR.Left+xControl.Width, xR.Top+xControl.Height);

  with TOHighlightForm.CreateNew(Self) do begin
    ShowAt(Self, xR, 3);
  end;
end;

end.

Answer 1

不要在CreateParams中测试HandleAllocation，当然它还没有被...

procedure TOHighlightForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

//  if HandleAllocated then // <------
  with Params do begin
    if Assigned(fxPopupParent) then
      WndParent := fxPopupParent.Handle;
  end;
end;

如果您不希望表单保持在顶部，请不要使用fsStayOnTop。

procedure TOHighlightForm.DoCreate;
begin
  inherited;

  Color := clRed;
//  FormStyle := fsStayOnTop; // <-----
  BorderStyle := bsNone;
  Position := poDesigned;
  DoubleBuffered := True;
end;

Self 是您的主要表单，您希望使用拥有框架的表单(模态表单)

procedure TForm1.HighlightButton(Sender: TObject);
var
  xR: TRect;
  xControl: TControl;
begin
  xControl := TControl(Sender);
  xR.TopLeft := xControl.ClientToScreen(Point(0, 0));
  xR.BottomRight := Point(xR.Left+xControl.Width, xR.Top+xControl.Height);

  with TOHighlightForm.CreateNew(Self) do begin  
    ShowAt(GetParentForm(TControl(Sender), False), xR, 3); // <--------
  end;
end;