delphi 屏幕拷贝程序的源代码


orland 公司的天才设计师们用画布(Tcanvas)对象封装了Windows
的大部分图形输出功能,这使得我们可以通过他以更直观的方
式和Windows 的屏幕打交道,而不必关心令人头疼的Windows API 函
数。

//下面的一小段程序就可以实现整个屏幕的图象拷贝了。

var //变量声明
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
//--
DC := GetDC (0); //取得屏幕的 DC,参数0指的是屏幕
FullscreenCanvas := TCanvas.Create; //创建一个CANVAS对象
FullscreenCanvas.Handle := DC; //将屏幕的DC赋给HANDLE
Fullscreen.Canvas.CopyRect
(Rect (0, 0, screen.Width,screen.Height),
fullscreenCanvas,
Rect (0, 0, Screen.Width, Screen.Height));
//把整个屏幕复制到BITMAP中
FullscreenCanvas.Free; //释放CANVAS对象
ReleaseDC (0, DC); //释放DC
//SCREEN对象是DELPHI预先定义的屏幕对象,直接使用就行了。


// 1. 首先新建一个工程。

//2. 在FORM 上放置一个TPANEL 元件,设置ALIGN=ALTOP,再选部件
条ADDITIONAL 上的TSCROLLBOX,放到FORM 上,设置ALIGN=ALCLIENT,
然后在SCROLLBOX 上放置一个TIMAGE 对象。

//3. 在PANEL 上放置4 个按钮,分别为FULL SCREEN,REGIN,SAVE,EXIT。

//4. 容易干的先干,在EXIT 按钮的CLICK 事件里写下代码

procedure TForm1.ExitClick(Sender: TObject);
begin
close;
end;
//5. 接着是实现全屏幕拷贝了,在FROM 上放置一个记时器
TTIMER,ENABLED 设为FALSE,INTERVAL 设为500,也就是半秒钟激活一
次。双击TIMER 部件,写上如下的代码。

procedure TForm1.Timer1Timer(Sender: TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
begin
timer1.Enabled:=false; //取消时钟
Fullscreen := TBitmap.Create;
//创建一个BITMAP来存放图象
Fullscreen.Width := screen.width;
Fullscreen.Height := screen.Height;
DC := GetDC (0);
//取得屏幕的 DC,参数0指的是屏幕
FullscreenCanvas :
= TCanvas.Create; //创建一个CANVAS对象
FullscreenCanvas.Handle := DC;

Fullscreen.Canvas.CopyRect (Rect
(0, 0, screen.Width, screen.Height), fullscreenCanvas,
Rect (0, 0, Screen.Width, Screen.Height));
//把整个屏幕复制到BITMAP中
FullscreenCanvas.Free; //释放CANVAS对象
ReleaseDC (0, DC); //释放DC
//*******************************
image1.picture.Bitmap:=
fullscreen;//拷贝下的图象赋给IMAGE对象
image1.Width:=fullscreen.Width;
image1.Height:=fullscreen.Height;
fullscreen.free; //释放bitmap
form1.WindowState:=wsNormal; //复原窗口状态
form1.show; //显示窗口
messagebeep(1);
//BEEP叫一声,报告图象已经截取好了。
end;
//6. 接下去FULLSCREEN 按钮上的代码就很简单了。

procedure TForm1.FullscreenClick(Sender: TObject);
begin
form1.WindowState:=wsMinimized; //最小化程序窗口
form1.hide; //把程序藏起来
timer1.enabled:=true; //打开记时器
end;
//7. 拷贝到了图象当然要存起来了,SAVE 按钮就有了用武之地,
我们写下如下代码。

procedure TForm1.Save1Click(Sender: TObject);
begin
if savedialog1.Execute then
begin
form1.Image1.Picture.SaveToFile(savedialog1.filename)
end;
end;
//8. 下面是区域拷贝的实现。再New 一个FORM,BorderStype 设为 bsNone,
这样能够显示为全屏幕,上面放置一个TIMAGE 部件,ALIGN 设为
ALCLIENT,另外放置一个TTIMER 部件,TIMER 部件的程序跟上面的
很象,因为它首先要实现的是全屏幕的拷贝。

procedure TForm2.Timer1Timer(Sender: TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
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;
form2.WindowState:=wsMaximized;
form2.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;
//9.TIMAGE 部件上有两个事件的程序需要编写,一个是
ONMOUSEDOWN,另一个是ONMOUSEMOVE。

//10. 可以回头看看区域拷贝的思路,此时需要作区域拷贝的屏
幕我们已经得到,也显示在屏幕上了,按下鼠标左键是区域的原
点,此后移动鼠标,将有一个矩形在原点和鼠标之间,它会随着
鼠标的移动而变化,再次按下鼠标的左键,此时矩形所包含的区
域就是我们要得到的图象了。

//11. 所以MOUSEDOWN 有两次响应的处理,见以下程序。

procedure TForm2.Image1MouseDown
(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
width,height:integer;
newbitmap:Tbitmap;
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),form2.image1.canvas,
Rect (x1, y1,x2,y2)); //拷贝
form1.image1.picture.bitmap:=newbitmap; //放到FORM的IMAGE上
newbitmap.free;
form2.hide;
form1.show;
end;
end;
//12.MOUSEMOVE 的处理就是在原点和鼠标当前位置之间不断地
画矩形和擦除矩形。

procedure TForm2.Image1MouseMove
(Sender: TObject; Shift: TShiftState; X,
Y: 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;
//13. 好了,让我们回过头来编写REGION 按钮的代码。

procedure TForm1.RegionClick(Sender: TObject);
begin
form1.Hide;
form2.hide;
form2.Timer1.Enabled:=true;
end;
//好了,我们终于胜利完工!
联系电话:
020-00000000
联系电话:
020-00000000
联系电话:
020-12345678