Советы по Delphi
       

Плавающие панельки


Кто-нибудь пробовал создать форму, подобную "отстегивающимся" панелькам (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,OldTop : 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 beginSetCapture(Panel1.Handle);ScreenDC := GetDC(0);OldX := X;OldY := Y;OldLeft := X;OldTop := Y;MoveRect := BoundsRect;DrawFocusRect(ScreenDC,MoveRect);Moving := True;end;end;

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);begin
if Moving then beginDrawFocusRect(ScreenDC,MoveRect);OldX := X;OldY := Y;MoveRect := Rect(Left+OldX-OldLeft,Top+OldY-OldTop,Left+Width+OldX-OldLeft,Top+Height+OldY-OldTop);DrawFocusRect(ScreenDC,MoveRect);end;end;

procedure TForm1.Panel1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);begin
if Button = mbLeft then beginReleaseCapture;DrawFocusRect(ScreenDC,MoveRect);Left := Left+X-OldLeft;Top := Top+Y-OldTop;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 beginBorderStyle := bsSizeable;Top := Top-TitleHeight-BorderHeight;Height := Height+TitleHeight+2*BorderHeight;Left := Left-BorderWidth;Width := Width+2*BorderWidth;endelse beginBorderStyle := bsNone;Top := Top+TitleHeight+BorderHeight;Height := Height-TitleHeight-2*BorderHeight;Left := Left+BorderWidth;Width := Width-2*BorderWidth;end;end;

end.
<
/p> Коментарии

У меня есть один коментарий отностительно вышеприведенного кода: данная реализация сложней, чем она должна была быть. Все, что вы должны сделать - это обработать системное сообщение 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);privateprocedure 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.
[000100]


Содержание раздела