怎样在CANVAS上实现矩形橡皮筋，用鼠标拖拉即可画矩形(50分)

怎样在CANVAS上实现矩形橡皮筋，用鼠标拖拉即可画矩形

drawfocusrect

to cAkk:
drawfocusrect 是哪里的函数？

很简单
设一个变量
var down:bool;
当鼠标按下时
down:=true;
SetRop2(Canvas.Handle,R2_XORPEN);
设置画图方式为xor方式。
记下当前的坐标x0,y0。
oldx:=x0;
oldy:=y0;

当鼠标移动时,如果down为true
先用
Canvas.Rectangle(x0,y0,oldx,oldy);
擦去原来的图形
然后在当前位置画矩形
Canvas.Rectangle(x0,y0,X,Y);
oldx:=X;
oldY:=Y;

当鼠标抬起时
down:=false
SetRop2(Canvas.Handle,R2_COPYPEN);
设置绘图方式为Copy方式
Canvas.Rectangle(x0,y0,oldx,oldy);
画矩形

请看如下代码
画线

var
Form1: TForm1;
OrignXY, MoveXY: TPoint;
Drawing:Boolean=false;

implementation

{$R *.DFM}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
OrignXY:=Point(x,y);
MoveXY:=OrignXY;
With OrignXY, Canvas do
MoveTo(x,y);
with Canvas,MoveXY do
Lineto(x,y);
Drawing:=true;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Drawing then
begin
With OrignXY,Canvas do
MoveTo(x,y);
with Canvas,MoveXY do
Canvas.LineTo(x,y);
With OrignXY,Canvas do
MoveTo(x,y);
MoveXY:=Point(x,y);
with Canvas,MoveXY do
LineTo(x,y);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Canvas.Pen.Mode:=pmNotXor;
Canvas.Pen.Color:=clRed;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Drawing:=false;
end;


画矩形

var
Form1: TForm1;
StartPt, EndPt : TPoint;
Drawing: Boolean;
implementation

{$R *.DFM}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
With Canvas do
begin
Pen.Mode := pmNot;
Pen.Color := clBlack;
Brush.Style := bsClear;
end;

StartPt:= Point(x,y);
EndPt:= StartPt;
Drawing:= True;
SetCapture(Handle);

end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Drawing then
begin
Canvas.Ellipse(StartPt.x,StartPt.y,EndPt.x,EndPt.y);
EndPt := Point(x,y);
Canvas.Ellipse(StartPt.x,StartPt.y,EndPt.x,EndPt.y);
end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Drawing := False;
Canvas.Ellipse(StartPt.x,StartPt.y,EndPt.x,EndPt.y);

With Canvas do
begin
Pen.Mode := pmCopy;
Brush.Color := clBlue;
Brush.Style := bsSolid;
end;
Canvas.Ellipse(StartPt.x,StartPt.y,EndPt.x,EndPt.y);
end;

end.

To Fencer
fencer的方法用鼠标拖拉矩形时如果矩形由小变大可以，但如由大变小时就不能擦除前一次的图形。

我的程序是顺手写的没验证过，不过由小变大可以那么由大变小也
应该行，我的程序不全是不是你的填充模式没改成空的形式，画出
的钜形是不是中间有东西？如果还不行我再做个程序试一下。

欢迎看：
http://www.huzhou.zj.cn/~fhb/
有CAD的例子

搞定此程序刚在Delphi5中运行通过
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button=mbLeft then
begin
down:=True;
Canvas.Brush.Style:=bsClear;
Canvas.Pen.Color:=clRed;
Canvas.Pen.Width:=1;
SetCapture(Handle);
x0:=X;
y0:=Y;
OldX:=X;
OldY:=Y;
end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if down then
begin
SetRop2(Canvas.Handle,R2_XORPEN);
Canvas.Rectangle(x0,y0,OldX,OldY);
Canvas.Rectangle(x0,y0,X,Y);
OldX:=X;
OldY:=Y;
end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button=mbLeft then
begin
down:=False;
SetRop2(Canvas.Handle,R2_COPYPEN);
ReleaseCapture;
Canvas.Rectangle(x0,y0,X,Y);
end;
end;

cAkk说的DrawFocusRect 是比较好的办法,它采用像素异或的方法画图,
擦除后对背景没有任何影响,画框和擦除框采用同一个函数,
第一次调用画框,第二次调用擦除!
可以做出类似于在windows主背景上按下鼠标,拉出一个框的效果.

设置全局变量
Rect : TRect记录位置,
MouseButtonDown:Boolean记录鼠标状态

OnMouseDown事件中
记录当前位置了left,top,Rigth:=Left,Bottom:=Top
鼠标状态为true
OnMouseMove事件内
判断鼠标状态
先擦除原图
修改Rect的right,bottom
画图
OnMouseUp事件
鼠标状态为法false;
详细请看下面程序:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TForm1 = class(TForm)
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

var
MouseButtonDown:Boolean;
Rect:TRect;

{$R *.DFM}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseButtonDown := True;
with Rect do
begin
Left := x;
Top := y;
Right := x;
Bottom := y;
end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Not MouseButtonDown then Exit;
Canvas.DrawFocusRect(Rect);
with Rect do
begin
Right := x;
Bottom := y;
end;
Canvas.DrawFocusRect(Rect);
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseButtonDown := False;
Canvas.DrawFocusRect(Rect);

end;

end.

这道题很简单,只要用好canvas.drawfoucsrect即可,
记住:每次发生mousemove事件时,应在使用一次canvas.drawfoucsrect
以便清除上一次的矩形,使得客户去只有一个矩形出现.

源代码来了:
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TForm1 = class(TForm)
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
fdragging:boolean;
frect:Trect;
x1,y1:integer;
implementation

{$R *.DFM}

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if fdragging
then begin
canvas.DrawFocusRect(frect);
frect.Right:=x;
frect.Bottom:=y;
if x1>x then begin
frect.left:=x;
frect.Right:=x1;
end;
if y1>y then begin
frect.top:=y;
frect.Bottom:=y1;
end;
canvas.DrawFocusRect(frect);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
fdragging:=false;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if button=mbleft
then begin
fdragging:=true;
setcapture(handle);
frect.Left:=x;
frect.Top:=y;
frect.BottomRight:=frect.TopLeft;
canvas.DrawFocusRect(frect);
x1:=x;y1:=y;
end;

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin

fdragging:=false;
canvas.DrawFocusRect(frect);
if fdragging
then begin
releasecapture;
fdragging:=false;
invalidate;
end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
canvas.Rectangle(frect.left,frect.top
,frect.right,frect.bottom);
end;

end.
就是这样了!

hey,dingdang你的程序有漏洞噢!
不信,你试试从右向左,从上向下的方向拖动鼠标,好像没有反应噢!

在心，你的程序理论上完美。但实际上也有一点小问题：
当你自右而左，再快速的自左而右，画出来矩形，左边会偏离起始中线，
这是由于Tform1.FormMouseMove这个过程系统是按一定的时间间隔执行。
修改后的程序如下：

unit Unit1;

interface

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

type
Tform1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);

private
{ Private declarations }
public
{ Public declarations }
end;

var
form1: Tform1;
fdragging:boolean;
frect:Trect;
x1,y1:integer;
implementation

{$R *.DFM}

procedure Tform1.FormCreate(Sender: TObject);
begin
fdragging:=false;
end;

procedure Tform1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if button=mbleft then
begin
fdragging:=true;
frect.Left:=x;
frect.Top:=y;
frect.BottomRight:=frect.TopLeft;
canvas.DrawFocusRect(frect);
x1:=x;y1:=y;
end;

end;
procedure Tform1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
fdragging:=false;
canvas.DrawFocusRect(frect);
end;


procedure Tform1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if fdragging then
begin
canvas.DrawFocusRect(frect);
if x1>x then
begin
frect.left:=x;
frect.Right:=x1;
end
else
begin
frect.left:=x1;
frect.right:=x;
end;
if y1>y then
begin
frect.top:=y;
frect.Bottom:=y1;
end
else
begin
frect.top:=y1;
frect.bottom:=y;
end;
canvas.DrawFocusRect(frect);
end;
end;

end.

对不起,dedmen,你的程序,我有疑问?
加于不加else有什么区别呢?

以水平方向而论：
if x1>x
then {鼠标当前位置在起始左边｝
else {鼠标当前位置在起始右边｝
我解决你程序中出现的异常，主要就是增加else,在右边时也重新赋值。
因为，按你的程序，如先向左拉一个矩形：
frect.left:=x;
frect.Right:=x1;
再向右快速拉过去，（条件：a.左键不放b.要快）
由于onmousemove这个事件,并不是真的move就执行，它有一定的interval,
如由左变右刚好在这个interval两端，
即事件在左边执行一次，紧接着在右边执行一次
此时x>x1;则按程序，
frect.right:=x;
frect.left并没再赋值，保持不变.
矩形的左边就会偏离起始中线。

I think I have got it!Thank you,dedmen!

dedman,not dedmen
新年好!

dedmen dedmen dedmen dedmen dedmen dedmen dedmen dedmen

看来我要改名了.真惨