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 !
From:http://tw.wingwit.com/Article/program/Delphi/201311/8540.html
