Прямоугольник как в Photoshopе

← →
mobila (2006-03-16 09:01) [0]

Подскажите пожалуйста как сделать чтобы прямоугольник можно было перетаскивать мышкой как в фотошопе.
листинг приведён ниже.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;

procedure Button1Click(Sender: TObject);

private
{ Private declarations }
Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;

public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.dfm}

function MakeRect(Pt1: TPoint; Pt2: TPoint): TRect;
begin
if pt1.x < pt2.x then
begin
Result.Left := pt1.x;
Result.Right := pt2.x;
end
else
begin
Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y < pt2.y then
begin
Result.Top := pt1.y;
Result.Bottom := pt2.y;
end
else
begin
Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Captured then
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace, EndPlace));
StartPlace.x := 0;
StartPlace.y := 176;
EndPlace.x := 132;
EndPlace.y := 0;
DrawFocusRect(Form1.Canvas.Handle, MakeRect(StartPlace, EndPlace));
end;
end.

← →
Andrey.Ru (2006-03-19 18:06) [1]

Обрабатывай MouseDown, MouseUp и MouseMove. Создай булевый флаг, переменную, В событии MouseDown и MouseUp меняй ее значение с труе на фолс, а При каждом смещении курсора в обработчике события MouseMove с учетом своего флага состояния кнопки мыши, прерисовывай свою канву начисто и сразу по твоему ректу отрисовывай ФокусРект с новым Лефтом и топом.

← →
mobila (2006-03-21 14:47) [2]

Спасибо всё получилось.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Button1Click(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;
leftX, topY, RectWidth, RectHeight: integer;

public
{ Public declarations }
end;

var
Form1: TForm1;
x0, y0: integer;
{Captured : boolean; }
R, R0: TRect;

implementation

{$R *.dfm}

//рисуем четырёх угольник
function MakeRect(Pt1: TPoint; Pt2: TPoint): TRect;
begin
if pt1.x < pt2.x then
begin
Result.Left := pt1.x;
Result.Right := pt2.x;
end
else
begin
Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y < pt2.y then
begin
Result.Top := pt1.y;
Result.Bottom := pt2.y;
end
else
begin
Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //левая кнопка нажата
begin
if button<>mbLeft then Captured:=false
else begin
Captured := true;
x0 := x;
y0 := y;

end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer); //находится в движении
begin
if Captured then
begin
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
EndPlace.x := EndPlace.x + x - x0;
EndPlace.y := EndPlace.y + y - y0;

StartPlace.x := StartPlace.x + x - x0;
StartPlace.y := StartPlace.y + y - y0;

x0 := x;
y0 := y;
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); //левая кнопка отпущина
begin

Captured := false;
Capturing := false;
x0 := x;
y0 := y;
end;

//задаём размеры четырёх угольнику
procedure TForm1.Button1Click(Sender: TObject);
begin
DrawFocusRect(Form1.Canvas.Handle, MakeRect(StartPlace, EndPlace));
StartPlace.x := 0;
StartPlace.y := 176;
EndPlace.x := 132;
EndPlace.y := 0;
DrawFocusRect(Form1.Canvas.Handle, MakeRect(StartPlace, EndPlace));
end;

end.

Прямоугольник как в Photoshopе Найти похожие ветки