delphi一个抓屏的函数


本文整理自网络,侵删。

 一个抓屏的函数,在其它Blog上看到的 Code
unit Main;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;

type
TMainFrm = class(TForm)
Button1: TButton;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
procedure ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);
public
{ Public declarations }
end;

var
MainFrm: TMainFrm;

implementation

{$R *.dfm}

//调用方法
procedure TMainFrm.Button1Click(Sender: TObject);
var
tBM : TBitmap;
begin
try
tBM := TBitmap.Create;
ScreenShot(0,0,Screen.Width,Screen.height,tBM);
tBM.SaveToFile('c:\ScreenShot.BMP');
Image1.Picture.Bitmap := tBM;
//image1.Picture.LoadFromFile('c:\screenshot.bmp');
finally
tBm.FreeImage;
FreeAndNil(tBM);
end;
end;

procedure TMainFrm.Button2Click(Sender: TObject);
begin
Self.Close;
end;

procedure TMainFrm.ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);
var
dc: HDC; lpPal : PLOGPALETTE;
begin
// 检测所需抓屏的区域
if ((Width = 0) or (Height = 0)) then exit;
bm.Width := Width;
bm.Height := Height;
//获取设备上下文
dc := GetDc(0);
if (dc = 0) then exit;
{do we have a palette device?}
if (GetDeviceCaps(dc, RASTERCAPS) AND
RC_PALETTE = RC_PALETTE) then
begin
{allocate memory for a logical palette}
GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
{zero it out to be neat}
FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
{fill in the palette version}
lpPal^.palVersion := $300;
{grab the system palette entries}
lpPal^.palNumEntries :=
GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
begin
{create the palette}
bm.Palette := CreatePalette(lpPal^);
end;
FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
end;
{copy from the screen to the bitmap}
BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,x,y,SRCCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;

end.

相关阅读 >>

Delphi 通过程序窗体句柄获取程序路径

Delphi串口api函数

Delphi fdconnection执行sql execsql

Delphi xe 下打开内存泄漏调试功能

Delphi 判断文本文件是否utf-8编码

Delphi 获得每个进程的cpu使用率

Delphi getmem(mystring,1024);//开辟1024个字节freemem(mystring,1024);//释放

Delphi调用android振动功能

Delphi下用cdo发送邮箱实例(授权码cdo发送邮箱的解决办法)

Delphi 透明窗体

更多相关阅读请进入《Delphi》频道 >>



打赏

取消

感谢您的支持,我会继续努力的!

扫码支持
扫码打赏,您说多少就多少

打开支付宝扫一扫,即可进行扫码打赏哦

分享从这里开始,精彩与您同在

评论

管理员已关闭评论功能...