各位高手大哥~~~~~小女子诚恳的请教你们，谁有delphi实现抓屏的代码啊~~是可以抓一个区域的那种~~~ ( 积分: 50 )

各位高手大哥~~~~~小女子诚恳的请教你们，谁有delphi实现抓屏的代码啊~~是可以抓一个区域的那种~~~，如果能有写成ActiveX的代码就更好了，我是新手，希望哥哥们不要嫌我问的问题弱~~~~~谢谢了~~~~~

各位高手大哥~~~~~小女子诚恳的请教你们，谁有delphi实现抓屏的代码啊~~是可以抓一个区域的那种~~~，如果能有写成ActiveX的代码就更好了，我是新手，希望哥哥们不要嫌我问的问题弱~~~~~谢谢了~~~~~

unit uCatchShow;

interface

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

type
TfrmCatchShow = class(TForm)
ChildImage: TImage;
ChildTimer: TTimer;
procedure ChildTimerTimer(Sender: TObject);
procedure ChildImageMouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
procedure ChildImageMouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure FormClose(Sender: TObject
var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

var
frmCatchShow: TfrmCatchShow;
foldx,x1,y1,x2,y2,oldx,oldy,foldy : Integer;
Flag,Trace : Boolean;
implementation

uses uScreenCapture;

{$R *.DFM}

procedure TfrmCatchShow.ChildTimerTimer(Sender: TObject);
var
FullScreen: TBitmap;
FullScreenCanvas: TCanvas;
DC: HDC;
begin
DoubleBuffered := True
//双缓冲模式
ChildTimer.Enabled := False;
Fullscreen := TBitmap.Create;
Fullscreen.Width := Screen.width;
Fullscreen.Height := Screen.Height;
DC := GetDC(0);
FullScreenCanvas := TCanvas.Create;
FullScreenCanvas.Handle := DC;
FullScreen.Canvas.CopyRect(Rect(0, 0, Screen.Width, Screen.Height), FullScreenCanvas,
Rect(0, 0, Screen.Width, Screen.Height));
FullScreenCanvas.Free;
ReleaseDC(0,DC);
ChildImage.Picture.Bitmap := FullScreen;
ChildImage.Width := FullScreen.Width;
ChildImage.Height := FullScreen.Height;
FullScreen.Free;
frmCatchShow.WindowState := wsMaximized;
frmCatchShow.show;
MessageBeep(1);
foldx := -1;
foldy := -1;
ChildImage.Canvas.Pen.mode := pmNot
// 笔的模式为取反
ChildImage.Canvas.Pen.Color := clBlack
// 笔为黑色
ChildImage.Canvas.Brush.Style := bsClear
// 空白刷子
Flag := True;
end;


procedure TfrmCatchShow.ChildImageMouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
begin
if Trace then // 是否在追踪鼠标
begin // 是，擦除旧的矩形并画上新的矩形
with ChildImage.Canvas do
begin
rectangle(x1, y1, oldx, oldy);
Rectangle(x1, y1, x, y);
oldx := x;
oldy := y;
end;
end
else if Flag then // 在鼠标所在的位置上画十字
begin
with ChildImage.Canvas do
begin
MoveTo(foldx, 0)
// 擦除旧的十字
LineTo(foldx, Screen.Height);
MoveTo(0, foldy);
LineTo(Screen.Width,foldy);
MoveTo(x, 0)
// 画上新的十字
LineTo(x, Screen.Height);
MoveTo(0,y);
LineTo(Screen.Width, y);
foldx := x;
foldy := y;
end;
end;
end;

procedure TfrmCatchShow.ChildImageMouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
var
Width, Height : Integer;
NewBitmap : TBitmap;
begin
if (Trace = False) then // TRACE表示是否在追踪鼠标
begin // 首次点击鼠标左键，开始追踪鼠标。
Flag := False;
with ChildImage.canvas do
begin
MoveTo(foldx, 0);
LineTo(foldx, Screen.height);
MoveTo(0, foldy);
LineTo(Screen.width, foldy);
end;
x1 := x;
y1 := y;
oldx := x;
oldy := y;
Trace := True;
ChildImage.Canvas.Pen.mode := pmNot
// 笔的模式为取反
// 这样再在原处画一遍矩形，相当于擦除矩形。
ChildImage.Canvas.Pen.Color := clBlack
// 笔为黑色
ChildImage.Canvas.Brush.Style := bsClear
// 空白刷子
end
else
begin // 第二次点击，表示已经得到矩形了，把它拷贝到frmScreenCapture中的IMAGE部件上。
x2 := x;
y2 := y;
Trace := False;
ChildImage.Canvas.Rectangle(x1, y1, oldx, oldy);
Width := abs(x2-x1);
Height := abs(y2-y1);
frmScreenCapture.ShowImage.Width := Width;
frmScreenCapture.ShowImage.Height := Height;

NewBitmap := TBitmap.Create;
NewBitmap.Width := Width;
NewBitmap.Height := Height;
NewBitmap.Canvas.CopyRect
(Rect(0, 0, width, Height),frmCatchShow.ChildImage.Canvas,
Rect(x1, y1, x2, y2))
// 拷贝
frmScreenCapture.ShowImage.Picture.Bitmap := NewBitmap
// 放到frmCatchShow的ShowImage上
NewBitmap.Free;
frmCatchShow.Hide;
frmScreenCapture.Show;
end;
end;

procedure TfrmCatchShow.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caFree;
end;

end.

//***************************************************************
//*作者: 刀剑如梦
//*Email: yckxzjj@163.com
//*Delphi编程驿站 http://www.delphidak.com
//*本站宗旨：与您共同进步、成长！
//***************************************************************
unit uScreenCapture;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, ExtDlgs, Buttons, ComCtrls, Menus, JPEG , Registry,
WinSkinData, ActnList;

type
TfrmScreenCapture = class(TForm)
MainTimer: TTimer;
ShowImage: TImage;
SaveDialog: TSavePictureDialog;
TopPanel: TPanel;
StatusBar: TStatusBar;
AllSreenPanel: TPanel;
AllScreenSpeedBtn: TSpeedButton;
QuYueSreenPanel: TPanel;
AreaScreenSpeedBtn: TSpeedButton;
SavePanel: TPanel;
SaveSpeedBtn: TSpeedButton;
ExitPanel: TPanel;
ExitSpeedBtn: TSpeedButton;
OpenDialog: TOpenDialog;
OpenDlgPanel: TPanel;
OpenDlgSpeedBtn: TSpeedButton;
SystemTimer: TTimer;
ScrollBox: TScrollBox;
PopupMenu: TPopupMenu;
N1: TMenuItem;
N5: TMenuItem;
N2: TMenuItem;
N6: TMenuItem;
N3: TMenuItem;
N8: TMenuItem;
N4: TMenuItem;
N7: TMenuItem;
pm_AutoScreen: TMenuItem;
AutoScreenPanel: TPanel;
AutoScreenSpeedBtn: TSpeedButton;
SkinData: TSkinData;
MainMenu1: TMainMenu;
N9: TMenuItem;
N10: TMenuItem;
N11: TMenuItem;
N12: TMenuItem;
N13: TMenuItem;
N14: TMenuItem;
ActionList1: TActionList;
AllScreen: TAction;
AreaScreen: TAction;
Save: TAction;
procedure MainTimerTimer(Sender: TObject);
procedure AllScreenSpeedBtnClick(Sender: TObject);
procedure AreaScreenSpeedBtnClick(Sender: TObject);
procedure SaveSpeedBtnClick(Sender: TObject);
procedure ExitSpeedBtnClick(Sender: TObject);
procedure FormClose(Sender: TObject
var Action: TCloseAction);
procedure SystemTimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure pm_AutoScreenClick(Sender: TObject);
procedure AutoScreenSpeedBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure OpenDlgSpeedBtnClick(Sender: TObject);
private
public
procedure BMPToJPG(BmpFileName:string);
Procedure MsgBox;
end;

var
frmScreenCapture: TfrmScreenCapture;

implementation

uses uCatchShow, uAutoScreen, uRegSoft, uRegTable;

{$R *.DFM}

// 自定义函数,随机取得4位a到z之间字符串,作为JPG格式图像的文件名
function RandomFileName():String;
var
PicName : string;
I : Integer;
begin
Randomize;
for I := 1 to 4 do
PicName := PicName + Chr(97 + Random(26));
RandomFileName := PicName;
end;

procedure TfrmScreenCapture.BMPToJPG(BmpFileName:string);
var
Jpeg : TJPEGImage;
Bmp : TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile(BmpFileName);
Jpeg := TJPEGImage.Create;
try
Jpeg.Assign(Bmp);
Jpeg.Compress;
// 以随机文件名保存在与EXE文件同目录下
Jpeg.SaveToFile(ExtractFilePath(Application.ExeName) + RandomFileName + '.jpg');
finally
Jpeg.Free;
end;
finally
Bmp.Free;
end;
end;

procedure TfrmScreenCapture.MainTimerTimer(Sender: TObject)
// 截取屏幕，并保存到Image控件中
var
Fullscreen : TBitmap;
FullscreenCanvas : TCanvas;
DC : HDC;
begin
MainTimer.Enabled := False
// 取消时钟
Fullscreen:=TBitmap.Create
// 创建一个BITMAP来存放图象
Fullscreen.Width := Screen.Width;
Fullscreen.Height := Screen.Height;
DC:=GetDC(0)
// 取得屏幕的DC，参数0指的是屏幕
FullscreenCanvas := TCanvas.Create
// 创建一个CANVAS对象
FullscreenCanvas.Handle := DC;

Fullscreen.Canvas.CopyRect
(Rect(0,0,Screen.Width,Screen.Height),FullScreenCanvas,
Rect(0,0,Screen.Width,Screen.Height));
// 把整个屏幕复制到BITMAP中
FullScreenCanvas.Free
// 释放CANVAS对象
ReleaseDC(0,DC)
// 释放DC
//*******************************
ShowImage.Picture.Bitmap := FullScreen
// 拷贝下的图象赋给IMAGE对象
ShowImage.Width := FullScreen.Width;
ShowImage.Height := FullScreen.Height;
FullScreen.Free
// 释放Bitmap
frmScreenCapture.WindowState := wsNormal
// 复原窗口状态
frmScreenCapture.Show
// 显示窗口
MessageBeep(1)
// BEEP叫一声，报告图象已经截取好了。
end;

procedure TfrmScreenCapture.AllScreenSpeedBtnClick(Sender: TObject)
// 全屏截图
begin
frmScreenCapture.WindowState := wsMinimized
// 最小化程序窗口
frmScreenCapture.Hide
// 把程序藏起来
MainTimer.Enabled := True
// 打开记时器
end;

procedure TfrmScreenCapture.AreaScreenSpeedBtnClick(Sender: TObject)
// 区域截图
begin
try
begin
frmScreenCapture.Hide;
frmCatchShow := TfrmCatchShow.Create(Application);
frmCatchShow.Hide;
frmCatchShow.ChildTimer.Enabled := True;
end
except
MsgBox;
Application.Terminate;
end;
end;

procedure TfrmScreenCapture.SaveSpeedBtnClick(Sender: TObject)
// 保存图片
begin
SaveDialog.Title := '※→友情提醒 ←※：图片保存后将被转换成随机文件';
if SaveDialog.Execute then
begin
frmScreenCapture.ShowImage.Picture.SaveToFile(SaveDialog.FileName);
BMPToJPG(SaveDialog.FileName);
DeleteFile(SaveDialog.FileName);
end;
end;

procedure TfrmScreenCapture.ExitSpeedBtnClick(Sender: TObject);
begin
Close;
end;

procedure TfrmScreenCapture.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caFree;
end;

procedure TfrmScreenCapture.MsgBox;
begin
with Application do
MessageBox('程序内部错误',PChar(Title),MB_OK+MB_ICONERROR);
end;

procedure TfrmScreenCapture.SystemTimerTimer(Sender: TObject);
var
DateTime : TDateTime;
begin
DateTime := Now;
StatusBar.Panels[1].Text := DateTimeToStr(DateTime);
end;

procedure TfrmScreenCapture.FormCreate(Sender: TObject);
var
RegF: TRegistry;
begin
// 读取注册表,根据是否设置了开机自动运行,而设置pm_AutoScreen的状态
RegF := TRegistry.Create;
RegF.RootKey := HKEY_LOCAL_MACHINE;
try
RegF.OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Run', True);
if RegF.ValueExists('ScreenCapture') then
pm_AutoScreen.Checked := True
else
pm_AutoScreen.Checked := False;
except
MsgBox;
end;
RegF.CloseKey;
RegF.Free;
end;

procedure TfrmScreenCapture.pm_AutoScreenClick(Sender: TObject);
var RegF: TRegistry;
begin
RegF := TRegistry.Create;
RegF.RootKey := HKEY_LOCAL_MACHINE;
try
RegF.OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Run',True);
// 设置开机是否自动运行
if pm_AutoScreen.Checked then
begin
RegF.DeleteValue('ScreenCapture');
RegF.WriteString('ScreenCapture', Application.ExeName);
end
else
RegF.DeleteValue('ScreenCapture');
except
MsgBox;
end;
RegF.CloseKey;
RegF.Free;
end;

procedure TfrmScreenCapture.AutoScreenSpeedBtnClick(Sender: TObject);
begin
if AutoScreenSpeedBtn.Caption = '停止截图' then
begin
frmAutoScreen.AutoScreenTimer.Enabled := False;
AutoScreenSpeedBtn.Caption := '自动截图';
end
else
begin
frmAutoScreen := TfrmAutoScreen.Create(Application);
frmAutoScreen.Show;
end;
end;

procedure TfrmScreenCapture.FormShow(Sender: TObject);
begin
if RegSoftFrm.RegwareII.Registered then Exit;
if RegTableFrm = nil then
RegTableFrm := TRegTableFrm.Create(self);
RegTableFrm.ShowModal;
RegTableFrm.Free;
RegTableFrm := nil;
end;

procedure TfrmScreenCapture.OpenDlgSpeedBtnClick(Sender: TObject);
begin
OpenDialog.Filter := 'Skin files(*.skn)|*.SKN';
OpenDialog.Initialdir := '../Skins/';
if OpenDialog.Execute then
SkinData.SkinFile := OpenDialog.FileName;
if not SkinData.Active then
SkinData.Active := True;
end;

end.

unit uAutoScreen;

interface

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

type
TfrmAutoScreen = class(TForm)
SetSpinEdit: TSpinEdit;
Label1: TLabel;
Label2: TLabel;
AutoScreenTimer: TTimer;
AppBitBtn: TBitBtn;
procedure AppBitBtnClick(Sender: TObject);
procedure FormClose(Sender: TObject
var Action: TCloseAction);
procedure AutoScreenTimerTimer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
frmAutoScreen: TfrmAutoScreen;

implementation

uses uScreenCapture;

{$R *.dfm}

procedure TfrmAutoScreen.AppBitBtnClick(Sender: TObject);
begin
AutoScreenTimer.Enabled := True;
AutoScreenTimer.Interval := StrToInt(SetSpinEdit.Text)*1000;
frmAutoScreen.Hide;
if frmAutoScreen.AutoScreenTimer.Enabled then
begin
SetWindowPos(frmAutoScreen.Handle, HWND_TOPMOST, frmAutoScreen.Left, frmAutoScreen.Top, frmAutoScreen.Width, frmAutoScreen.Height,0);
frmScreenCapture.AutoScreenSpeedBtn.Caption := '停止截图';
end;
end;

procedure TfrmAutoScreen.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
AutoScreenTimer.Enabled := False;
Action:= caFree;
end;

procedure TfrmAutoScreen.AutoScreenTimerTimer(Sender: TObject);
var
BuildBMP: TBitmap;
c: TCanvas;
r,t: TRect;
h: THandle;
ExeFilePath: string;
begin
ExeFilePath := ExtractFilePath(Application.ExeName);
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
// 获得当前活动窗口的句柄
h := GetForeGroundWindow;
BuildBMP := TBitmap.Create;
if h <> 0 then
// 结构t保存该窗口的左上角和右下角的坐标值(相对于屏幕左上角)
GetWindowRect(h, t);
try
r := Rect(0, 0, t.Right-t.Left, t.Bottom-t.Top);
BuildBMP.Width := t.Right-t.Left;
BuildBMP.Height := t.Bottom-t.Top;
BuildBMP.Canvas.CopyRect(r, c, t);
// 截屏结果保存在与EXE相同目录下
BuildBMP.SaveToFile(ExeFilePath + 'AutoScreen.bmp');
finally
BuildBMP.Free;
end;
// 将文件转换成JPG格式,以减少磁盘空间的占用
frmScreenCapture.BMPToJPG(ExeFilePath + 'AutoScreen.bmp');
end;


end.

哥哥，你的程序好详细啊，我好兴奋，呵呵：）
不过我看的还是有点费劲[]，你能大概给我描述一下，每个unit是具体做什么的吗？我看好像不只是矩形抓屏，还有抓全屏，真是太感谢了[][:I]

汗颜，总算找到一个比我还菜的菜鸟了！这位牛人兄的代码已经很清楚了啊。实在看不懂的话，你把不同的UNIT的代码拷贝到你自己新建的单元/窗体中，根据代码中的东西，添加相关的组件，这样对你应该是有帮助的，然后再还有不懂的东西的话，就可以上来问牛人兄了，呵呵。

是啊，我真的是很菜哦，我才开始学Delphi，很多东西还很模糊，这个程序是非常详细，不过我的能力实在是有限，吃力的阅读ing.......[]

用Delphi的mm，你可要加油哦。

非常感谢

to 刀剑如梦:
你好,我也搞了一个抓屏的.但只能抓矩形的,请问如何能抓圆形或其他形状??