Delphi抓屏开发
- 格式：docx
- 大小：16.86 KB
- 文档页数：12
四种抓屏效果开发
抓全屏幕
procedure CatchFullScreen;
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, SRCCOPY
or CAPTUREBLT);
// 存到剪切板
Clipboard.Assign(bmp); bmp.SaveToFile(BmpFileName);
finally
bmp.Free;
ReleaseDC(0, DesktopDC);
self.Show;
end;
end;
窗口抓屏
procedure CapWindowClick(var msg: TMsg); message UM_LBUTTONDOWN;
const
{$ifndef CAPTUREBLT} CAPTUREBLT = $40000000;
{$endif}
RCCORE_DLL_NAME = 'MouseHook.dll';
var
LibHandle: THandle;
柄
SetHook: TSetHook;
RemoveHook: TRemoveHook;
LastBmp: TBitmap;
LastHandle: HWND;
Rect, RectDis: TRect;
procedure TForm1.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; procedure TForm1.LoadDll;
begin
try
LibHandle := LoadLibrary(RCCORE_DLL_NAME);
if LibHandle = 0 then
begin ShowMessage('"' + RCCORE_DLL_NAME + '" 载入失败！ '); Exit; //DLL 句 end;
@SetHook := GetProcAddress(LibHandle, PChar('SetHook'));
@RemoveHook := GetProcAddress(LibHandle, PChar('RemoveHook')); except
ShowMessage('dll 载入失败！ ');
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Pos: TPoint;
Handle: HWND;
begin
GetCursorPos(Pos); // 得到当前光标位 置
Handle := WindowFromPoint(Pos); // 返回当前位置的句柄
if LastHandle <> Handle then
begin
if LastHandle <> 0 then
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,
SRCCOPY or CAPTUREBLT);
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; procedure TForm1.CapWindowClick(var msg: 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,
SRCCOPY or CAPTUREBLT);
Clipboard.Assign(LastBmp);
LastBmp.SaveToFile(TempBmpName);
self.Show;
end;
procedure TForm1.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;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ReleaseDC(0, DesktopDC);
LastBmp.Free;
FreeDll;
end;
鼠标钩子动态库
library MouseHook;
{ Important note about DLL memory management: ShareMem must be the first unit in your library's
USES clause AND your project's (select Project-View Source) USES clause if your DLL exports
any procedures or functions that pass strings as parameters or function results. This applies to all
strings passed to and from your DLL--even those that are nested in records and classes.
ShareMem is the interface unit to the BORLNDMM.DLL shared memory manager, which must be
deployed along with your DLL. To avoid using BORLNDMM.DLL, pass string information using PChar or ShortString parameters. }
uses
SysUtils, Classes, Windows, Messages;
const
UM_LBUTTONDOWN = WM_USER + 1000;
var
Hooked: Boolean; hHook: Integer;
{$R *.res}
function HookProc(code: Integer; wp: WPARAM; lp: LPARAM): LRESULT; stdcall; var
hr: HWND;
begin
if (wp = WM_LBUTTONDOWN) then
begin
hr := FindWindow('TForm1', 'Form1'); if hr <> 0 then
SendMessage(hr, UM_LBUTTONDOWN, 0, 0); end;
// 鼠标是公用资源，慎重使用。
// 隐藏鼠标光标，实际上只是看不见而已。
// 但已经达到目的，因为下一步，钓住了发往
// 别的窗口的鼠标消息。
// 中断发往别的窗口鼠标消息链。 result := 1;
end;
function SetHook: Boolean; stdcall; begin
result := False;
if Hooked then
Exit;
hHook := SetWindowsHookEx(WH_MOUSE, HookProc, HInstance, 0); result := hHook <> 0;
end;
function RemoveHook: Boolean; stdcall; begin
result := False;
if (not Hooked) and (hHook <> 0) then begin
result := UnHookWindowsHookEx(hHook); end;
Hooked := False;
end;
exports SetHook name 'SetHook', RemoveHook name 'RemoveHook';
begin
Hooked := False;
