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

Written on . Posted in [Delphi] Стандартные классы, VCL

ОГЛАВЛЕНИЕ

Кто-нибудь пробовал создать форму, подобную "отстегивающимся" панелькам (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.

форум микроконтроллеры