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测试HandleAllocated，当然它一直没有...

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; 

自我是你的主要形式是，你要使用该将自己的框架为什么不躲红色边框形式（模式窗体）

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;