Плавающие окна

← →
Hooch (2002-09-06 07:25) [0]

День добрый !
Проблема такова: есть mdiChid форма, поверх неё должна плавать форма, не выходя за пределы mdiChild. Если в качестве ParentWindow плавающей формы задать mdiChild, то все работает нормально, но начинаются проблемы с фокусом, в частности, если мышкой кликать на Edit-ах, расположеных на плавающем окне, на них не переходит фокус и если фокус находится на компоненте плавающего окна он не всегда возвращается в родительское. Не подскажет ли кто решение проблемы с фокусом или другой, относительно простой, способ реализации плавающего окна, не выходящего за пределы родителя ?

← →
msts (2002-09-06 13:59) [1]

//----------------

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}
uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
with TForm2.Create(Self) do begin
ManualDock(Self);
Visible := true;
Left := 10;
Top := 10;
end;
end;

end.

//----------------
unit Unit2;

interface

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

type
TForm2 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Label1: TLabel;
Panel1: TPanel;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTESt;
procedure Panel1Enter(Sender: TObject);
procedure Label1MouseLeave(Sender: TObject);
procedure Label1MouseEnter(Sender: TObject);
private
{ Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public declarations }
end;

var
Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := Style or ({WS_CAPTION or} WS_THICKFRAME{ or WS_MINIMIZEBOX or
WS_MAXIMIZEBOX or WS_SYSMENU})
//WS_CAPTION - изза этого флага фокус не переходит - почему ? - не знаю - не искал
end;

procedure TForm2.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
//вариант 1 таскаем за форму
//if Message.Result = HTCLIENT then Message.Result := HTCAPTION;
//вариант 2 таскаем за надпись
if PtInRect(Label1.BoundsRect ,Self.ScreenToClient(Point(Message.Pos.x,Message.Pos.y)))
then Message.Result := HTCAPTION;
end;

procedure TForm2.Panel1Enter(Sender: TObject);
begin
// на Panel1 лежат компоненты кроме Label1
Self.BringToFront;
end;

procedure TForm2.Label1MouseLeave(Sender: TObject);
begin
TLabel(Sender).Font.Color:=clWindowText;
end;

procedure TForm2.Label1MouseEnter(Sender: TObject);
begin
TLabel(Sender).Font.Color:=clRed;
end;

end.

Плавающие окна Найти похожие ветки