分享
 
 
 

一 个 实 用 的Delphi 屏 幕 拷 贝 程 序 的 设

王朝delphi·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

一 个 实 用 的Delphi 屏 幕 拷 贝 程 序 的 设 计

宁 波 市 游 河 巷 贾 学 杰

---- Borland 公 司( 现 改 名 为INPRISE 公 司) 的DELPHI 是 当 前 最 为 方 便 的Windows 程 序 设

计 工 具 之 一。 许 多 人 以 为DELPHI 是 作 为 数 据 库 开 发 工 具 出 现 的, 其 实 用DELPHI

可 以 以 极 快 的 速 度 开 发 出 高 效 的Windows 程 序。

---- 现 在 我 们 就 用DELPHI 来 编 写 一 个 实 用 的 屏 幕 拷 贝 程 序。 瞧 瞧, 下 面 的 画 面

就 是 所 编 程 序 运 行 后 进 行 区 域 屏 幕 拷 贝 的 例 子, 还 不 错 吧 !

---- Borland 公 司 的 天 才 设 计 师 们 用 画 布(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预先定义的屏幕对象,直接使用就行了。

---- 看 了 以 上 代 码, 你 就 会 发 现 用DELPHI 写 屏 幕 拷 贝 程 序 的 确 很 简 单。

---- 当 然 要 写 一 个 实 用 的 屏 幕 拷 贝 程 序, 光 靠 上 述 代 码 是 不 够 的, 下 面 讲 一

下 主 要 的 编 程 思 路:

---- 1. 全 屏 幕 拷 贝 的 实 现

---- 首 先 隐 藏 拷 屏 程 序, 延 长 一 定 时 间 后, 利 用 上 述 的 程 序 即 可 实 现 屏 幕 的

拷 贝。

---- 2. 区 域 拷 贝 的 实 现

---- 要 实 现 区 域 拷 贝 要 用 个 小 技 巧, 首 先 调 用 全 屏 幕 拷 贝 程 序 把 整 个 屏 幕 拷

贝 下 来, 然 后 把 拷 贝 下 来 的 图 象 显 示 在 屏 幕 上, 之 后 就 可 以 让 用 户 在 上 面

选 择 需 要 的 区 域, 最 后 才 将 用 户 选 定 的 区 域 复 制 下 来。

---- 编 程 实 现:

---- 1. 首 先 用DELPHI3 开 一 个 工 程。

---- 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 不 仅 是 一 个 优 秀 的 数 据 库 开 发 工 具, 而 且 是 一 个 优 秀 的 编 写WINDOWS

程 序 的 好 帮 手。 让 我 们 不 禁 赞 叹: 伟 大 的DELPHI !

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有