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

Кто-нибудь пробовал создать форму, подобную "отстегивающимся" панелькам (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 begin SetCapture(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 begin DrawFocusRect(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 begin ReleaseCapture; 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 begin BorderStyle := bsSizeable; Top := Top-TitleHeight-BorderHeight; Height := Height+TitleHeight+2*BorderHeight; Left := Left-BorderWidth; Width := Width+2*BorderWidth; end else begin BorderStyle := bsNone; Top := Top+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.

[000100]

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