Плавающая панель
Falk0ner, вс, 06/07/2008 - 15:34.
http://delphiworld.narod.ru/
DelphiWorld 6.0
Текст в модуле с "плавающей" панелью:
Плавающая панель Кто-нибудь пробовал создать форму, подобную "отстегивающимся" панелькам (FreeDoc)? Я попробовал и вот что получилось... Код требует использования некоторых функций WinAPI. Описание всех WinAPI функций доступны при нажатии F1 (электронная справка)... Ну а теперь попробуем это создать (весь код занимает около 100 строчек)... Ход работы: Стартуйте новый проект, задайте свойству borderstyle формы значение bsNone, добавьте панель, установите у нее свойство borderstyle равным значению bsSingle, добавьте другую панель с любым заголовком, добавьте кнопку с подсказкой 'переключатель панели заголовка', вырежьте из данного совера код и вставьте его в модуль, создайте обработчики трех событий панелей (MouseDown, MouseMove, MouseUp) и один обработчик кнопки (Click). Надеюсь, что ничего не забыл... ;-) Быстрее сделать это в Delphi, чем написать здесь... ;-)
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Button1: TButton;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
OldX,
OldY,
OldLeft,
Old: Integer;
ScreenDC: HDC;
MoveRect: TRect;
Moving: Boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
SetCapture(Panel1.Handle);
ScreenDC := GetDC(0);
OldX := X;
OldY := Y;
OldLeft := X;
Old := Y;
MoveRect := BoundsRect;
DrawFocusRect(ScreenDC, MoveRect);
Moving := True;
end;
end;
procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Moving then
begin
DrawFocusRect(ScreenDC, MoveRect);
OldX := X;
OldY := Y;
MoveRect := Rect(Left + OldX - OldLeft, + OldY - Old,
Left + Width + OldX - OldLeft, + Height + OldY - Old);
DrawFocusRect(ScreenDC, MoveRect);
end;
end;
procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
DrawFocusRect(ScreenDC, MoveRect);
Left := Left + X - OldLeft;
:= + Y - Old;
ReleaseDC(0, ScreenDC);
Moving := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TitleHeight,
BorderWidth,
BorderHeight: Integer;
begin
TitleHeight := GetSystemMetrics(SM_CYCAPTION);
BorderWidth := GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXFRAME) -
1;
BorderHeight := GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYFRAME) -
2;
if BorderStyle = bsNone then
begin
BorderStyle := bsSizeable;
:= - TitleHeight - BorderHeight;
Height := Height + TitleHeight + 2 * BorderHeight;
Left := Left - BorderWidth;
Width := Width + 2 * BorderWidth;
end
else
begin
BorderStyle := bsNone;
:= + TitleHeight + BorderHeight;
Height := Height - TitleHeight - 2 * BorderHeight;
Left := Left + BorderWidth;
Width := Width - 2 * BorderWidth;
end;
end;
end.
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Button1: TButton;
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
OldX,
OldY,
OldLeft,
Old: Integer;
ScreenDC: HDC;
MoveRect: TRect;
Moving: Boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
SetCapture(Panel1.Handle);
ScreenDC := GetDC(0);
OldX := X;
OldY := Y;
OldLeft := X;
Old := Y;
MoveRect := BoundsRect;
DrawFocusRect(ScreenDC, MoveRect);
Moving := True;
end;
end;
procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Moving then
begin
DrawFocusRect(ScreenDC, MoveRect);
OldX := X;
OldY := Y;
MoveRect := Rect(Left + OldX - OldLeft, + OldY - Old,
Left + Width + OldX - OldLeft, + Height + OldY - Old);
DrawFocusRect(ScreenDC, MoveRect);
end;
end;
procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
DrawFocusRect(ScreenDC, MoveRect);
Left := Left + X - OldLeft;
:= + Y - Old;
ReleaseDC(0, ScreenDC);
Moving := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TitleHeight,
BorderWidth,
BorderHeight: Integer;
begin
TitleHeight := GetSystemMetrics(SM_CYCAPTION);
BorderWidth := GetSystemMetrics(SM_CXBORDER) + GetSystemMetrics(SM_CXFRAME) -
1;
BorderHeight := GetSystemMetrics(SM_CYBORDER) + GetSystemMetrics(SM_CYFRAME) -
2;
if BorderStyle = bsNone then
begin
BorderStyle := bsSizeable;
:= - TitleHeight - BorderHeight;
Height := Height + TitleHeight + 2 * BorderHeight;
Left := Left - BorderWidth;
Width := Width + 2 * BorderWidth;
end
else
begin
BorderStyle := bsNone;
:= + TitleHeight + BorderHeight;
Height := Height - TitleHeight - 2 * BorderHeight;
Left := Left + BorderWidth;
Width := Width - 2 * BorderWidth;
end;
end;
end.
Коментарии
У меня есть один коментарий отностительно вышеприведенного кода: данная реализация сложней, чем она должна была быть. Все, что вы должны сделать - это обработать системное сообщение wm_NCHitTest. Я приведу здесь код, который я создал для Borland Tech Info, и который выполняет ту же функцию:
unit Dragmain;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited; { вызвали наследованный дескриптор сообщения, }
if M.Result = htClient then { кликнув в области окна? }
M.Result := htCaption; { если так, то мы заставили Windows думать, }
{ что это область заголовка. }
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
end.
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited; { вызвали наследованный дескриптор сообщения, }
if M.Result = htClient then { кликнув в области окна? }
M.Result := htCaption; { если так, то мы заставили Windows думать, }
{ что это область заголовка. }
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
end.
http://delphiworld.narod.ru/
DelphiWorld 6.0
Так называемая "плавающая панель" используется обычно для панелей инструментов.
Текст в модуле с основной формой:
procedure TForm1.FormShow(Sender: TObject);
begin
Form2.Show;
end;
begin
Form2.Show;
end;
Текст в модуле с "плавающей" панелью:
private
procedure CreateParams(var Params: TCreateParams); override;
...
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
begin
Style := Style or WS_OVERLAPPED;
WndParent := Form1.Handle;
end;
end;
procedure CreateParams(var Params: TCreateParams); override;
...
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
begin
Style := Style or WS_OVERLAPPED;
WndParent := Form1.Handle;
end;
end;
http://delphiworld.narod.ru/ DelphiWorld 6.0
Отправить комментарий