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; 
//好了，我们终于胜利完工！
delphi 屏幕拷贝程序的源代码

相关推荐

评论
