Delphi抓屏开发0313121639.docx
- 文档编号:6955412
- 上传时间:2023-01-13
- 格式:DOCX
- 页数:15
- 大小:18.22KB
Delphi抓屏开发0313121639.docx
《Delphi抓屏开发0313121639.docx》由会员分享,可在线阅读,更多相关《Delphi抓屏开发0313121639.docx(15页珍藏版)》请在冰豆网上搜索。
Delphi抓屏开发0313121639
四种抓屏效果开发
抓全屏幕
procedureCatchFullScreen;
var
DesktopDC:
HDC;
bmp:
TBitmap;
begin
DesktopDC:
=GetDC(0);
bmp:
=TBitmap.Create;
try
self.Hide;bmp.PixelFormat:
=pf24bit;bmp.Width:
=Screen.Width;bmp.Height:
=Screen.Height;bmp.Canvas.Brush.Style:
=bsClear;
//CAPTUREBLT为抓透明窗体,如果不抓透明窗体,则去掉该标识,该标识需要自定义
BitBlt(bmp.Canvas.Handle,0,0,Screen.Width,Screen.Height,DesktopDC,0,0,SRCCOPYorCAPTUREBLT);
//存到剪切板
Clipboard.Assign(bmp);bmp.SaveToFile(BmpFileName);
finally
bmp.Free;
ReleaseDC(0,DesktopDC);
self.Show;
end;
end;
窗口抓屏
procedureCapWindowClick(varmsg:
TMsg);messageUM_LBUTTONDOWN;
const
{$ifndefCAPTUREBLT}
CAPTUREBLT=$40000000;
{$endif}
RCCORE_DLL_NAME='MouseHook.dll';
//DLL句
var
LibHandle:
THandle;
柄
SetHook:
TSetHook;
RemoveHook:
TRemoveHook;
LastBmp:
TBitmap;
LastHandle:
HWND;
Rect,RectDis:
TRect;
procedureTForm1.CatchWindow;
var
LastHandle:
HWND;
DesktopDC:
HDC;
DCCanvas:
TCanvas;
begin
self.Hide;
LastHandle:
=0;
DCCanvas:
=TCanvas.Create;
DCCanvas.Handle:
=DesktopDC;
DCCanvas.Brush.Style:
=bsClear;
Timer1.Enabled:
=True;
//设置鼠标钩子
SetHook;
end;procedureTForm1.LoadDll;
begin
try
LibHandle:
=LoadLibrary(RCCORE_DLL_NAME);
ifLibHandle=0then
beginShowMessage('"'+RCCORE_DLL_NAME+'"载入失败!
');Exit;
end;
@SetHook:
=GetProcAddress(LibHandle,PChar('SetHook'));
@RemoveHook:
=GetProcAddress(LibHandle,PChar('RemoveHook'));except
ShowMessage('dll载入失败!
');
end;
end;
procedureTForm1.Timer1Timer(Sender:
TObject);
var
Pos:
TPoint;
Handle:
HWND;
begin
GetCursorPos(Pos);//得到当前光标位置
Handle:
=WindowFromPoint(Pos);//返回当前位置的句柄
ifLastHandle<>Handlethen
begin
ifLastHandle<>0then
begin
DCCanvas.CopyRect(Rect,LastBmp.Canvas,LastBmp.Canvas.ClipRect);end;
LastHandle:
=Handle;GetWindowRect(Handle,Rect);
LastBmp.FreeImage;
LastBmp.Width:
=Rect.Right-Rect.Left;
LastBmp.Height:
=Rect.Bottom-Rect.Top;
BitBlt(LastBmp.Canvas.Handle,0,0,
Rect.Right-Rect.Left,
Rect.Bottom-Rect.Top,
DCCanvas.Handle,
Rect.Left,
Rect.Top,
SRCCOPYorCAPTUREBLT);
RectDis.Left:
=Rect.Left+2;
RectDis.Top:
=Rect.Top+2;
RectDis.Right:
=REct.Right-2;
RectDis.Bottom:
=REct.Bottom-2;
DCCanvas.Pen.Width:
=2;
DCCanvas.Pen.Style:
=psSolid;
DCCanvas.Pen.Color:
=clRed;
DCCanvas.Rectangle(RectDis);
end;
end;
procedureTForm1.CapWindowClick(varmsg:
TMsg);
begin
RemoveHook;
Timer1.Enabled:
=False;
DCCanvas.CopyRect(Rect,LastBmp.Canvas,LastBmp.Canvas.ClipRect);
BitBlt(LastBmp.Canvas.Handle,0,0,
Rect.Right-Rect.Left,
Rect.Bottom-Rect.Top,
DCCanvas.Handle,
Rect.Left,
Rect.Top,
SRCCOPYorCAPTUREBLT);
Clipboard.Assign(LastBmp);
LastBmp.SaveToFile(TempBmpName);
self.Show;
end;
procedureTForm1.FormCreate(Sender:
TObject);
begin
LastBmp:
=TBitmap.Create;
LastBmp.PixelFormat:
=pf24bit;
LastBmp.Width:
=Screen.Width;
LastBmp.Height:
=Screen.Height;
LastBmp.Canvas.Brush.Style:
=bsClear;
DesktopDC:
=GetDC(0);
//载入鼠标钩子动态库
LoadDll;
end;
procedureTForm1.FormDestroy(Sender:
TObject);
begin
ReleaseDC(0,DesktopDC);
LastBmp.Free;
FreeDll;
end;
鼠标钩子动态库
libraryMouseHook;
{ImportantnoteaboutDLLmemorymanagement:
ShareMemmustbethefirstunitinyourlibrary'sUSESclauseANDyourproject's(selectProject-ViewSource)USESclauseifyourDLLexportsanyproceduresorfunctionsthatpassstringsasparametersorfunctionresults.ThisappliestoallstringspassedtoandfromyourDLL--eventhosethatarenestedinrecordsandclasses.ShareMemistheinterfaceunittotheBORLNDMM.DLLsharedmemorymanager,whichmustbedeployedalongwithyourDLL.ToavoidusingBORLNDMM.DLL,passstringinformationusingPCharorShortStringparameters.}
uses
SysUtils,Classes,Windows,Messages;
const
UM_LBUTTONDOWN=WM_USER+1000;
var
Hooked:
Boolean;hHook:
Integer;
{$R*.res}
functionHookProc(code:
Integer;wp:
WPARAM;lp:
LPARAM):
LRESULT;stdcall;var
hr:
HWND;
begin
if(wp=WM_LBUTTONDOWN)then
begin
hr:
=FindWindow('TForm1','Form1');ifhr<>0then
SendMessage(hr,UM_LBUTTONDOWN,0,0);end;
//鼠标是公用资源,慎重使用。
//隐藏鼠标光标,实际上只是看不见而已。
//但已经达到目的,因为下一步,钓住了发往
//别的窗口的鼠标消息。
//中断发往别的窗口鼠标消息链。
result:
=1;
end;
functionSetHook:
Boolean;stdcall;begin
result:
=False;
ifHookedthen
Exit;
hHook:
=SetWindowsHookEx(WH_MOUSE,HookProc,HInstance,0);result:
=hHook<>0;
end;
functionRemoveHook:
Boolean;stdcall;begin
result:
=False;
if(notHooked)and(hHook<>0)thenbegin
result:
=UnHookWindowsHookEx(hHook);end;
Hooked:
=False;
end;
exportsSetHookname'SetHook',RemoveHookname'RemoveHook';
begin
Hooked:
=False;
end.
矩形区域抓屏
procedureTForm1.CatchRectScreen;
var
bmp:
TBitmap;
DesktopDC:
HDC;
begin
DesktopDC:
=GetDC(0);
bmp:
=TBitmap.Create;
try
self.Hide;
bmp.PixelFormat:
=pf24bit;bmp.Width:
=Screen.Width;bmp.Height:
=Screen.Height;bmp.Canvas.Brush.Style:
=bsClear;
BitBlt(bmp.Canvas.Handle,0,0,Screen.Width,Screen.Height,DesktopDC,0,0,SRCCOPYorCAPTUREBLT);
//抓屏时,新建一个窗体,先将整个屏幕抓图放在新建窗体中,再在该窗体上截取矩形图片
FormScreen.Image1.Picture.Bitmap:
=bmp;
FormScreen.Image1.Align:
=alClient;
FormScreen.Left:
=0;
FormScreen.Top:
=0;
FormScreen.Width:
=Screen.Width;
FormScreen.Height:
=Screen.Height;
FormScreen.Cursor:
=crCross;
FormScreen.ShowModal;
finally
bmp.Free;
ReleaseDC(0,DesktopDC);
self.Show;
end;
end;
//放置全屏抓图的窗体
unitUnitScreen;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,Dialogs,ExtCtrls,UnitMain,Clipbrd;
type
TFormScreen=class(TForm)
Image1:
TImage;
procedureFormKeyDown(Sender:
TObject;varKey:
Word;
Shift:
TShiftState);
procedureImage1MouseDown(Sender:
TObject;Button:
TMouseButton;Shift:
TShiftState;X,Y:
Integer);
procedureImage1MouseMove(Sender:
TObject;Shift:
TShiftState;X,Y:
Integer);
procedureImage1MouseUp(Sender:
TObject;Button:
TMouseButton;Shift:
TShiftState;X,Y:
Integer);
private
{Privatedeclarations}
RectShape:
TShape;
IsPoint:
Boolean;
Point:
TPoint;
Arect:
TRect;
public
{Publicdeclarations}
end;
var
FormScreen:
TFormScreen;
implementation
{$R*.dfm}
procedureTFormScreen.FormKeyDown(Sender:
TObject;varKey:
Word;
Shift:
TShiftState);
begin
ifKey=VK_ESCAPEthen
self.Close;
end;
procedureTFormScreen.Image1MouseDown(Sender:
TObject;
Button:
TMouseButton;Shift:
TShiftState;X,Y:
Integer);var
dc:
HDC;
bmp:
TBitmap;
begin
ifssRightinShiftthen
Self.Close;
if(IsPoint=True)and(ssLeftinShift)and(ssDoubleinShift)thenbegin
IsPoint:
=False;
bmp:
=TBitmap.Create;bmp.PixelFormat:
=pf24bit;
bmp.Width:
=RectShape.Width;bmp.Height:
=RectShape.Height;bmp.Canvas.Brush.Style:
=bsClear;
dc:
=GetDC(0);
try
dc,
BitBlt(bmp.Canvas.Handle,0,0,RectShape.Width,RectShape.Height,RectShape.Left,RectShape.Top,SRCCOPYorCAPTUREBLT);
Clipboard.Assign(bmp);bmp.SaveToFile(TempBmpName);
finallyReleaseDC(0,dc);bmp.Free;RectShape.Free;
end;
self.Close;
end
elseif(IsPoint=False)and(ssLeftinShift)thenbegin
RectShape:
=TShape.Create(self);
RectShape.Parent:
=self;
RectShape.Brush.Style:
=bsClear;
RectShape.Pen.Color:
=clRed;
RectShape.Shape:
=stRectangle;RectShape.OnMouseDown:
=Image1MouseDown;RectShape.Left:
=X;
RectShape.Top:
=Y;
end;
end;
procedureTFormScreen.Image1MouseMove(Sender:
TObject;Shift:
TShiftState;
X,Y:
Integer);
begin
ifnotIsPointthen
begin
GetCursorPos(Point);
if(PtInRect(Arect,Point)=True)thenCursor:
=crSizeAll
else
Cursor:
=crCross;
ifssLeftinshiftthen//判断鼠标左键是下按着.
begin
RectShape.Width:
=X-RectShape.Left;
RectShape.Height:
=Y-RectShape.Top;
end;
end;
end;
procedureTFormScreen.Image1MouseUp(Sender:
TObject;Button:
TMouseButton;Shift:
TShiftState;X,Y:
Integer);
begin
IsPoint:
=True;
end;
end.
自由画图形抓图
procedureTForm1.CatchFreeScreen;
var
DesktopDC:
HDC;
bmp:
TBitmap;
begin
DesktopDC:
=GetDC(0);
bmp:
=TBitmap.Create;
try
self.Hide;
bmp.PixelFormat:
=pf24bit;
bmp.Width:
=Screen.Width;bmp.Height:
=Screen.Height;bmp.Canvas.Brush.Style:
=bsClear;
DesktopDC,0,
BitBlt(bmp.Canvas.Handle,0,0,Screen.Width,Screen.Height,0,SRCCOPYorCAPTUREBLT);
//新建一个窗体放置截取全屏的图片,再在新窗体的图片上截取部分图片
FormFreeCap.Image1.Picture.Bitmap:
=bmp;FormFreeCap.Image1.Align:
=alClient;
FormFreeCap.Left:
=0;
FormFreeCap.Top:
=0;
FormFreeCap.Width:
=Screen.Width;
FormFreeCap.Height:
=Screen.Height;
FormFreeCap.Cursor:
=crCross;
FormFreeCap.ShowModal;
finally
bmp.Free;
ReleaseDC(0,DesktopDC);
self.Show;
end;
end;
//放置全屏图片的新窗体
unitUnitFreeCap;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,ExtCtrls,Clipbrd,UnitMain;
type
TFormFreeCap=class(TForm)
Image1:
TImage;
procedureFormKeyDown(Sender:
TObject;varKey:
Word;
Shift:
TShiftState);
procedureImage1MouseDown(Sender:
TObject;Button:
TMouseButton;
Shift:
TShiftState;X,Y:
Integer);
procedureImage1MouseMove(Sender:
TObject;Shift:
TShiftState;X,
Y:
Integer);
procedureImage1MouseUp(Sender:
TObject;Button:
TMouseButton;Shift:
TShiftState;X,Y:
Integer);
procedureFormShow(Sender:
TObject);
private
{Privatedeclarations}
Point,StartPoint,LastPoint:
TPoint;
BmpLeft,BmpTop,BmpRight,BmpBottom:
Integer;
Arect:
TRect;
AryPoint:
arrayofTPoint;
NumPoint:
Integer;
public
{Publicdeclarations}
end;
var
FormFreeCap:
TFormFreeCap;
implementation
{$R*.dfm}
procedureTFormFreeCap.FormKeyDown(Sender:
TObject;varKey:
Word;Shift:
TShiftState);
begin
ifKey=VK_ESCAPEthenself.Close;
end;
procedureTFormFreeCap.Image1MouseDown(Sender:
TObject;
Button:
TMouseButton;Shift:
TShiftState;X,Y:
Integer);begin
ifssRightinShiftthenSelf.Close;
if(ssLeftinShift)then
beginStartPoint.X:
=X;StartPoint.Y:
=Y;
LastPoint.X:
=X;
LastPoint.Y:
=Y
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- Delphi 开发 0313121639
![提示](https://static.bdocx.com/images/bang_tan.gif)