V
vsice
Unregistered / Unconfirmed
GUEST, unregistred user!
网上找的一段代码，我改了一点点，作用是：
鼠标点击选取image1区域，把选中的区域的copy到image2中，在运行时第一幅图片选取正常，但点击Button1重新读取图片后，再选取图片时就不正常（反白），怎么回事？,另外就是还会划线不正常，存在这两个问题。谁给我看看，很急用，帮帮我，或者谁还有同样的代码，发给我vsice@163.com.
原代码如下：
--------------------------------------
unit FrmMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Timer1: TTimer;
Image2: TImage;
Button1: TButton;
procedure Timer1Timer(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
foldx,foldy,x1,y1,oldx,oldy,x2,y2 : integer;
flag,trace : boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Timer1Timer(Sender: TObject);
var
Fullscreen:Tbitmap;
// FullscreenCanvas:TCanvas;
dc:HDC;
//foldx,foldy: integer;
//flag : boolean;
begin
timer1.Enabled:=false;
// Fullscreen:=TBitmap.Create;
// Fullscreen.Width:=screen.width;
// Fullscreen.Height:=screen.Height;
// DC:=GetDC(0);
// FullscreenCanvas:=TCanvas.Create;
// FullscreenCanvas.Handle:=DC;
// Fullscreen.Canvas.CopyRect(Rect(0,0,screen.Width,screen.Height),fullscreenCanvas,Rect(0,0,Screen.Width,Screen.Height));
// FullscreenCanvas.Free;
// ReleaseDC(0,DC);
// image1.picture.Bitmap:=fullscreen;
// image1.Width:=fullscreen.Width;
// image1.Height:=fullscreen.Height;
// fullscreen.free;
// form1.WindowState:=wsMaximized;
// form1.show;
messagebeep(1);
foldx:=-1;
foldy:=-1;
image1.Canvas.Pen.mode:=pmnot;//笔的模式为取反
image1.canvas.pen.color:=clblack;//笔为黑色
image1.canvas.brush.Style:=bsclear;//空白刷子
flag:=true;
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
width,height:integer;
newbitmap:Tbitmap;
//trace,flag : boolean;
begin
if(trace=false)then //TRACE表示是否在追踪鼠标
begin //首次点击鼠标左键，开始追踪鼠标。
flag:=false;
with image1.canvas do
begin
// moveTo(foldx,0);
LineTo(foldx,screen.height);
// moveto(0,foldy);
lineto(screen.width,foldy);
end;
x1:=x;
y1:=y;
oldx:=x;
oldy:=y;
trace:=true;
// image1.Canvas.Pen.mode:=pmnot; //笔的模式为取反
//这样再在原处画一遍矩形，相当于擦除矩形。
// image1.canvas.pen.color:=clblack; //笔为黑色
// image1.canvas.brush.Style:=bsclear;//空白刷子
end
else
begin //第二次点击，表示已经得到矩形了，
//把它拷贝到FORM1中的IMAGE部件上。
x2:=x;
y2:=y;
trace:=false;
image1.canvas.rectangle(x1,y1,oldx,oldy);
width:=abs(x2-x1);
height:=abs(y2-y1);
// form1.image1.Width:=Width;
// form1.image1.Height:=Height;
newbitmap:=Tbitmap.create;
newbitmap.width:=width;
newbitmap.height:=height;
newbitmap.Canvas.CopyRect(Rect(0,0,width,Height),form1.image1.canvas,Rect(x1,y1,x2,y2));//拷贝
// form1.image1.picture.bitmap:=newbitmap;//放到FORM的IMAGE上
image2.Picture.Assign(newbitmap);
newbitmap.free;
// form1.hide;
// form1.show;
end;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
//var trace,flag : boolean;
// x1,y1,oldx,oldy,foldx,foldy : integer;
begin
if trace=true then //是否在追踪鼠标？
begin //是，擦除旧的矩形并画上新的矩形
with image1.canvas do
begin
rectangle(x1,y1,oldx,oldy);
Rectangle(x1,y1,x,y);
oldx:=x;
oldy:=y;
end;
end
else if flag=true then //在鼠标所在的位置上画十字
begin
with image1.canvas do
begin
// moveTo(foldx,0); //擦除旧的十字
LineTo(foldx,screen.height);
// moveto(0,foldy);
lineto(screen.width,foldy);
// moveTo(x,0); //画上新的十字
LineTo(x,screen.height);
// moveto(0,y);
lineto(screen.width,y);
foldx:=x;
foldy:=y;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
image1.Picture.LoadFromFile('C:/aa.bmp') ;
//form1.DoubleBuffered:=true;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
trace :=false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
image1.Picture.LoadFromFile('C:/dd.bmp') ;
end;
end.
//-----------------------------------
鼠标点击选取image1区域，把选中的区域的copy到image2中，在运行时第一幅图片选取正常，但点击Button1重新读取图片后，再选取图片时就不正常（反白），怎么回事？,另外就是还会划线不正常，存在这两个问题。谁给我看看，很急用，帮帮我，或者谁还有同样的代码，发给我vsice@163.com.
原代码如下：
--------------------------------------
unit FrmMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Timer1: TTimer;
Image2: TImage;
Button1: TButton;
procedure Timer1Timer(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
foldx,foldy,x1,y1,oldx,oldy,x2,y2 : integer;
flag,trace : boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Timer1Timer(Sender: TObject);
var
Fullscreen:Tbitmap;
// FullscreenCanvas:TCanvas;
dc:HDC;
//foldx,foldy: integer;
//flag : boolean;
begin
timer1.Enabled:=false;
// Fullscreen:=TBitmap.Create;
// Fullscreen.Width:=screen.width;
// Fullscreen.Height:=screen.Height;
// DC:=GetDC(0);
// FullscreenCanvas:=TCanvas.Create;
// FullscreenCanvas.Handle:=DC;
// Fullscreen.Canvas.CopyRect(Rect(0,0,screen.Width,screen.Height),fullscreenCanvas,Rect(0,0,Screen.Width,Screen.Height));
// FullscreenCanvas.Free;
// ReleaseDC(0,DC);
// image1.picture.Bitmap:=fullscreen;
// image1.Width:=fullscreen.Width;
// image1.Height:=fullscreen.Height;
// fullscreen.free;
// form1.WindowState:=wsMaximized;
// form1.show;
messagebeep(1);
foldx:=-1;
foldy:=-1;
image1.Canvas.Pen.mode:=pmnot;//笔的模式为取反
image1.canvas.pen.color:=clblack;//笔为黑色
image1.canvas.brush.Style:=bsclear;//空白刷子
flag:=true;
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
width,height:integer;
newbitmap:Tbitmap;
//trace,flag : boolean;
begin
if(trace=false)then //TRACE表示是否在追踪鼠标
begin //首次点击鼠标左键，开始追踪鼠标。
flag:=false;
with image1.canvas do
begin
// moveTo(foldx,0);
LineTo(foldx,screen.height);
// moveto(0,foldy);
lineto(screen.width,foldy);
end;
x1:=x;
y1:=y;
oldx:=x;
oldy:=y;
trace:=true;
// image1.Canvas.Pen.mode:=pmnot; //笔的模式为取反
//这样再在原处画一遍矩形，相当于擦除矩形。
// image1.canvas.pen.color:=clblack; //笔为黑色
// image1.canvas.brush.Style:=bsclear;//空白刷子
end
else
begin //第二次点击，表示已经得到矩形了，
//把它拷贝到FORM1中的IMAGE部件上。
x2:=x;
y2:=y;
trace:=false;
image1.canvas.rectangle(x1,y1,oldx,oldy);
width:=abs(x2-x1);
height:=abs(y2-y1);
// form1.image1.Width:=Width;
// form1.image1.Height:=Height;
newbitmap:=Tbitmap.create;
newbitmap.width:=width;
newbitmap.height:=height;
newbitmap.Canvas.CopyRect(Rect(0,0,width,Height),form1.image1.canvas,Rect(x1,y1,x2,y2));//拷贝
// form1.image1.picture.bitmap:=newbitmap;//放到FORM的IMAGE上
image2.Picture.Assign(newbitmap);
newbitmap.free;
// form1.hide;
// form1.show;
end;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
//var trace,flag : boolean;
// x1,y1,oldx,oldy,foldx,foldy : integer;
begin
if trace=true then //是否在追踪鼠标？
begin //是，擦除旧的矩形并画上新的矩形
with image1.canvas do
begin
rectangle(x1,y1,oldx,oldy);
Rectangle(x1,y1,x,y);
oldx:=x;
oldy:=y;
end;
end
else if flag=true then //在鼠标所在的位置上画十字
begin
with image1.canvas do
begin
// moveTo(foldx,0); //擦除旧的十字
LineTo(foldx,screen.height);
// moveto(0,foldy);
lineto(screen.width,foldy);
// moveTo(x,0); //画上新的十字
LineTo(x,screen.height);
// moveto(0,y);
lineto(screen.width,y);
foldx:=x;
foldy:=y;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
image1.Picture.LoadFromFile('C:/aa.bmp') ;
//form1.DoubleBuffered:=true;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
trace :=false;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
image1.Picture.LoadFromFile('C:/dd.bmp') ;
end;
end.
//-----------------------------------