Borland 公 司( 现 改 名 为INPRISE 公 司) 的DELPHI 是 当 前 最 为 方 便 的Windows 程 序 设计 工 具 之 一 许 多 人 以 为DELPHI 是 作 为 数 据 库 开 发 工 具 出 现 的 其 实 用DELPHI可 以 以 极 快 的 速 度 开 发 出 高 效 的Windows 程 序
现 在 我 们 就 用DELPHI 来 编 写 一 个 实 用 的 屏 幕 拷 贝 程 序
Borland 公 司 的 天 才 设 计 师 们 用 画 布(Tcanvas) 对 象 封 装 了Windows 的 大 部 分 图 形输 出 功 能 这 使 得 我 们 可 以 通 过 他 以 更 直 观 的 方 式 和Windows 的 屏 幕 打 交 道而 不 必 关 心 令 人 头 疼 的Windows API 函 数 下 面 的 一 小 段 程 序 就 可 以 实 现 整 个屏 幕 的 图 象 拷 贝 了
var //变量声明
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
DC := GetDC (); //取得屏幕的 DC参数指的是屏幕
FullscreenCanvas := TCanvasCreate; //创建一个CANVAS对象
FullscreenCanvasHandle := DC; //将屏幕的DC赋给HANDLE
FullscreenCanvasCopyRect (Rect ( screenWidthscreenHeight)
fullscreenCanvasRect ( ScreenWidth ScreenHeight));
//把整个屏幕复制到BITMAP中
FullscreenCanvasFree; //释放CANVAS对象
ReleaseDC ( DC); //释放DC
//SCREEN对象是DELPHI预先定义的屏幕对象直接使用就行了
看 了 以 上 代 码 你 就 会 发 现 用DELPHI 写 屏 幕 拷 贝 程 序 的 确 很 简 单 当 然 要 写 一 个 实 用 的 屏 幕 拷 贝 程 序 光 靠 上 述 代 码 是 不 够 的 下 面 讲 一下 主 要 的 编 程 思 路
全 屏 幕 拷 贝 的 实 现
首 先 隐 藏 拷 屏 程 序 延 长 一 定 时 间 后 利 用 上 述 的 程 序 即 可 实 现 屏 幕 的拷 贝
区 域 拷 贝 的 实 现
要 实 现 区 域 拷 贝 要 用 个 小 技 巧 首 先 调 用 全 屏 幕 拷 贝 程 序 把 整 个 屏 幕 拷贝 下 来 然 后 把 拷 贝 下 来 的 图 象 显 示 在 屏 幕 上 之 后 就 可 以 让 用 户 在 上 面选 择 需 要 的 区 域 最 后 才 将 用 户 选 定 的 区 域 复 制 下 来
编 程 实 现
首 先 用DELPHI 开 一 个 工 程
在FORM 上 放 置 一 个TPANEL 元 件 设 置ALIGN=ALTOP 再 选 部 件 条ADDITIONAL 上的TSCROLLBOX 放 到FORM 上 设 置ALIGN=ALCLIENT 然 后 在SCROLLBOX 上 放 置 一 个TIMAGE 对 象
在PANEL 上 放 置 个 按 钮 分 别 为FULL SCREENREGINSAVEEXIT
容 易 干 的 先 干 在EXIT 按 钮 的CLICK 事 件 里 写 下 代 码
procedure TFormExitClick(Sender: TObject);
begin
close;
end;
接 着 是 实 现 全 屏 幕 拷 贝 了 在FROM 上 放 置 一 个 记 时 器TTIMERENABLED 设 为FALSEINTERVAL 设 为 也 就 是 半 秒 钟 激 活 一 次 双 击TIMER 部 件 写 上 如 下 的代 码
procedure TFormTimerTimer(Sender: TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
begin
timerEnabled:=false; //取消时钟
Fullscreen := TBitmapCreate; //创建一个BITMAP来存放图象
FullscreenWidth := screenwidth;
FullscreenHeight := screenHeight;
DC := GetDC (); //取得屏幕的 DC参数指的是屏幕
FullscreenCanvas := TCanvasCreate; //创建一个CANVAS对象
FullscreenCanvasHandle := DC;
FullscreenCanvasCopyRect (Rect ( screenWidth screenHeight) fullscreenCanvasRect ( ScreenWidth ScreenHeight));
//把整个屏幕复制到BITMAP中
FullscreenCanvasFree; //释放CANVAS对象
ReleaseDC ( DC); //释放DC
imagepictureBitmap:=fullscreen;//拷贝下的图象赋给IMAGE对象
imageWidth:=fullscreenWidth;
imageHeight:=fullscreenHeight;
fullscreenfree; //释放bitmap
formWindowState:=wsNormal; //复原窗口状态
formshow; //显示窗口
messagebeep(); //BEEP叫一声报告图象已经截取好了
end;
接 下 去FULLSCREEN 按 钮 上 的 代 码 就 很 简 单 了
procedure TFormFullscreenClick(Sender: TObject);
begin
formWindowState:=wsMinimized; //最小化程序窗口
formhide; //把程序藏起来
timerenabled:=true; //打开记时器
end;
拷 贝 到 了 图 象 当 然 要 存 起 来 了SAVE 按 钮 就 有 了 用 武 之 地 我 们 写 下 如下 代 码
procedure TFormSaveClick(Sender: TObject);
begin
if savedialogExecute then
begin
formImagePictureSaveToFile(savedialogfilename)
end;
end;
下 面 是 区 域 拷 贝 的 实 现 再New 一 个FORMBorderStype 设 为 bsNone 这 样 能 够 显 示为 全 屏 幕 上 面 放 置 一 个TIMAGE 部 件ALIGN 设 为ALCLIENT 另 外 放 置 一 个TTIMER部 件TIMER 部 件 的 程 序 跟 上 面 的 很 象 因 为 它 首 先 要 实 现 的 是 全 屏 幕 的 拷贝
procedure TFormTimerTimer(Sender: TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
begin
timerEnabled:=false;
Fullscreen := TBitmapCreate;
FullscreenWidth := screenwidth;
FullscreenHeight := screenHeight;
DC := GetDC ();
FullscreenCanvas := TCanvasCreate;
FullscreenCanvasHandle := DC;
FullscreenCanvasCopyRect (Rect ( screenWidth screenHeight) fullscreenCanvasRect ( ScreenWidth ScreenHeight));
FullscreenCanvasFree;
ReleaseDC ( DC);
imagepictureBitmap:=fullscreen;
imageWidth:=fullscreenWidth;
imageHeight:=fullscreenHeight;
fullscreenfree;
formWindowState:=wsMaximized;
formshow;
messagebeep();
foldx:=;
foldy:=;
imageCanvasPenmode:=pmnot; //笔的模式为取反
imagecanvaspencolor:=clblack; //笔为黑色
imagecanvasbrushStyle:=bsclear; //空白刷子
flag:=true;
end;
TIMAGE 部 件 上 有 两 个 事 件 的 程 序 需 要 编 写 一 个 是ONMOUSEDOWN 另 一 个是ONMOUSEMOVE
可 以 回 头 看 看 区 域 拷 贝 的 思 路 此 时 需 要 作 区 域 拷 贝 的 屏 幕 我 们 已 经得 到 也 显 示 在 屏 幕 上 了 按 下 鼠 标 左 键 是 区 域 的 原 点 此 后 移 动 鼠 标 将有 一 个 矩 形 在 原 点 和 鼠 标 之 间 它 会 随 着 鼠 标 的 移 动 而 变 化 再 次 按 下 鼠标 的 左 键 此 时 矩 形 所 包 含 的 区 域 就 是 我 们 要 得 到 的 图 象 了
所 以MOUSEDOWN 有 两 次 响 应 的 处 理 见 以 下 程 序
procedure TFormImageMouseDown
(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X Y: Integer);
var
widthheight:integer;
newbitmap:Tbitmap;
begin
if (trace=false) then // TRACE表示是否在追蹤鼠标
begin //首次点击鼠标左键开始追蹤鼠标
flag:=false;
with imagecanvas do
begin
moveTo(foldx);
LineTo(foldxscreenheight);
moveto(foldy);
lineto(screenwidthfoldy);
end;
x:=x;
y:=y;
oldx:=x;
oldy:=y;
trace:=true;
imageCanvasPenmode:=pmnot; //笔的模式为取反
//这样再在原处画一遍矩形相当于擦除矩形
imagecanvaspencolor:=clblack; //笔为黑色
imagecanvasbrushStyle:=bsclear;//空白刷子
end
else
begin //第二次点击表示已经得到矩形了
//把它拷贝到FORM中的IMAGE部件上
x:=x;
y:=y;
trace:=false;
imagecanvasrectangle(xyoldxoldy);
width:=abs(xx);
height:=abs(yy);
formimageWidth:=Width;
formimageHeight:=Height;
newbitmap:=Tbitmapcreate;
newbitmapwidth:=width;
newbitmapheight:=height;
newbitmapCanvasCopyRect
(Rect ( width Height)formimagecanvas
Rect (x yxy)); //拷贝
formimagepicturebitmap:=newbitmap; //放到FORM的IMAGE上
newbitmapfree;
formhide;
formshow;
end;
end;
MOUSEMOVE 的 处 理 就 是 在 原 点 和 鼠 标 当 前 位 置 之 间 不 断 地 画 矩 形 和 擦除 矩 形
procedure TFormImageMouseMove
(Sender: TObject; Shift: TShiftState; X
Y: Integer);
begin
if trace=true then //是否在追蹤鼠标?
begin //是擦除旧的矩形并画上新的矩形
with imagecanvas do
begin
rectangle(xyoldxoldy);
Rectangle(xyxy);
oldx:=x;
oldy:=y;
end;
end
else if flag=true then //在鼠标所在的位置上画十字
begin
with imagecanvas do
begin
moveTo(foldx); //擦除旧的十字
LineTo(foldxscreenheight);
moveto(foldy);
lineto(screenwidthfoldy);
moveTo(x); //画上新的十字
LineTo(xscreenheight);
moveto(y);
lineto(screenwidthy);
foldx:=x;
foldy:=y;
end;
end;
end;
好 了 让 我 们 回 过 头 来 编 写REGION 按 钮 的 代 码
procedure TFormRegionClick(Sender: TObject);
begin
formHide;
formhide;
formTimerEnabled:=true;
end;
好 了 我 们 终 于 胜 利 完 工 了 赶 快 运 行 一 遍 把 漂 亮 的 屏 幕 拷 下 来 ! 瞧DELPHI 不 仅 是 一 个 优 秀 的 数 据 库 开 发 工 具 而 且 是 一 个 优 秀 的 编 写WINDOWS程 序 的 好 帮 手 让 我 们 不 禁 赞 歎 伟 大 的DELPHI !
