QQ的捕捉屏幕的程序
Panel1与lblRect是模仿QQ的那个小提示框，双击选中框时我并没有做什么处理 ，请大家自己看着办
unit
Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 =
class
(TForm)
Panel1: TPanel;
lblRect: TLabel;
procedure
FormCreate(Sender: TObject);
procedure
FormDestroy(Sender: TObject);
procedure
FormPaint(Sender: TObject);
procedure
FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure
FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure
FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure
FormKeyDown(Sender: TObject;
var
Key: Word;
Shift: TShiftState);
procedure
Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure
FormDblClick(Sender: TObject);
private
{ Private declarations }
procedure
DrawScreen;
procedure
DrawSelect;
function
GetMouseCursor(X, Y: Integer): Integer;
public
{ Public declarations }
end
;
var
Form1: TForm1;
ScreenBmp, CurrentBmp: TBitmap;
bMouseDown,
bMouseDown1,
//
用于
ReSizeFlag
bSelect, bMoveRect: Boolean;
SelectRect, LastSelectRect: TRect;
CurrentPoint: TPoint;
ReSizeFlag: integer;
implementation
uses
Types;
const
v =
4
;
//border width
{$R *.dfm}
function
CheckRect(R: TRect): TRect;
var
i: integer;
begin
if
r.Left > r.Right
then
begin
i := r.Left;
r.Left := r.Right;
r.Right := i;
end
;
if
r.Top > r.Bottom
then
begin
i := r.Top;
r.Top := r.Bottom;
r.Bottom := i;
end
;
result := r;
end
;
function
OffsetRect1(R: TRect; X, Y: integer): TRect;
begin
OffsetRect(R, X, Y);
Result := R;
end
;
function
InflateRect1(R: TRect; X, Y: integer): TRect;
begin
InflateRect(R, X, Y);
Result := R;
end
;
function
PtInRect1(R: TRect; p: TPoint): Boolean;
begin
Result := PtInRect(OffsetRect1(R, SelectRect.Left, SelectRect.Top), p);
end
;
function
CaptrueScreenRect(ARect: TRect): TBitmap;
var
ScreenDC: HDC;
begin
Result := TBitmap.Create;
with
Result, ARect
do
begin
Width := Right - Left;
Height := Bottom - Top;
ScreenDC := GetDC(
0
);
try
BitBlt(Canvas.Handle,
0
,
0
, Width, Height, ScreenDC, Left, Top, SRCCOPY);
finally
ReleaseDC(
0
, ScreenDC);
end
;
end
;
end
;
procedure
TForm1.FormCreate(Sender: TObject);
begin
ScreenBmp := TBitmap.Create;
CurrentBmp := TBitmap.Create;
ScreenBmp := CaptrueScreenRect(RECT(
0
,
0
, Screen.width, Screen.Height));
Self.BorderStyle := bsNone;
Self.WindowState := wsMaximized;
bMouseDown := False;
bSelect := False;
bMoveRect := False;
LastSelectRect := Rect(
0
,
0
,
0
,
0
);
ReSizeFlag := -
1
;
end
;
procedure
TForm1.FormDestroy(Sender: TObject);
begin
screenbmp.Free;
currentbmp.Free;
end
;
procedure
TForm1.FormPaint(Sender: TObject);
begin
DrawScreen;
end
;
function
TForm1.GetMouseCursor(X, Y: Integer): Integer;
var
p: TPoint;
W, H: integer;
begin
Result := -
1
;
p := Point(x, y);
W := SelectRect.Right - SelectRect.Left;
H := SelectRect.Bottom - SelectRect.Top;
if
PtInRect1(Rect(-v, -v, v, v), p)
then
//
左上角
Result :=
0
else if
PtInRect1(Rect(W - v, H - v, W, H), p)
then
//
右下角
Result :=
1
else if
PtInRect1(Rect(W - v,
0
, W, v), p)
then
//
右上角
Result :=
2
else if
PtInRect1(Rect(
0
, H - v, v, H), p)
then
//
左下角
Result :=
3
else if
PtInRect1(Rect(v,
0
, W - v, v), p)
then
//
上
Result :=
4
else if
PtInRect1(Rect(
0
, v, v, H - v), p)
then
//
左
Result :=
5
else if
PtInRect1(Rect(W - v, v, W, H - v), p)
then
//
右
Result :=
6
else if
PtInRect1(Rect(v, H - v, W - v, H), p)
then
//
下
Result :=
7
;
ReSizeFlag := Result;
end
;
procedure
TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
GetMouseCursor(X, Y);
if not
bSelect
then
begin
bMouseDown := True;
bSelect := True;
SelectRect.Left := x;
SelectRect.Top := y;
end
else
if
(ReSizeFlag <> -
1
)
{ or (ReSizeFlag <> 8)}
then
begin
bMouseDown1 := True;
end
else
if
PtInRect(InflateRect1(SelectRect, v, v), Point(x, y))
then
begin
bMoveRect := True;
CurrentPoint := Point(X, Y);
end
;
end
;
procedure
TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
p: TPoint;
W, H: integer;
begin
if
bMouseDown
then
//
选择区域
begin
SelectRect.Right := x;
SelectRect.Bottom := y;
DrawSelect;
exit;
end
;
if
bSelect
and
bMoveRect
then
//
进行区域移动处理
if
PtInRect(InflateRect1(SelectRect, v, v), Point(x, y))
then
begin
OffsetRect(SelectRect, X - CurrentPoint.X, Y - CurrentPoint.Y);
CurrentPoint := Point(X, Y);
DrawSelect;
exit;
end
;
if not
bMouseDown1
then
case
GetMouseCursor(x, y)
of
-
1
:
Self.Cursor := crDefault;
0
:
Self.Cursor := crSizeNWSE;
1
:
Self.Cursor := crSizeNWSE;
2
:
Self.Cursor := crSizeNESW;
3
:
Self.Cursor := crSizeNESW;
4
:
Self.Cursor := crVSplit;
5
:
Self.Cursor := crHSplit;
6
:
Self.Cursor := crHSplit;
7
:
Self.Cursor := crVSplit;
8
:
Self.Cursor := crSizeAll;
end
else
begin
case
ReSizeFlag
of
0
:
//
左上角
begin
SelectRect.Left := x;
SelectRect.Top := y;
end
;
1
:
//
右下角
begin
SelectRect.Right := x;
SelectRect.Bottom := y;
end
;
2
:
//
右上角
begin
SelectRect.Right := x;
SelectRect.Top := y;
end
;
3
:
//
左下角
begin
SelectRect.Left := x;
SelectRect.Bottom := y;
end
;
4
:
//
上
SelectRect.Top := y;
5
:
//
左
SelectRect.Left := X;
6
:
//
右
SelectRect.Right := X;
7
:
//
下
SelectRect.Bottom := y;
end
;
DrawSelect;
Exit;
end
;
if
bSelect
and not
bMoveRect
and not
bMouseDown1
then
//
检测鼠标是否移动到区域
if
PtInRect(InflateRect1(SelectRect, -v, -v), Point(x, y))
then
begin
Self.Cursor := crSizeAll;
end
;
end
;
procedure
TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
bMouseDown := False;
bMouseDown1 := False;
bMoveRect := False;
SelectRect := CheckRect(SelectRect);
end
;
procedure
TForm1.DrawScreen;
begin
canvas.Draw(
0
,
0
, ScreenBmp);
if
bSelect
then
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := clRed;
canvas.TextOut(
0
,
0
,
IntToStr(SelectRect.Left) +
','
+
IntToStr(SelectRect.Top) +
','
+
IntToStr(SelectRect.Right) +
','
+
IntToStr(SelectRect.Bottom));
Canvas.Rectangle(SelectRect);
end
;
end
;
procedure
TForm1.FormKeyDown(Sender: TObject;
var
Key: Word;
Shift: TShiftState);
begin
// showmessage(inttostr(Key));
case
Key
of
27
:
if
bSelect
then
begin
bSelect := False;
Self.Cursor := crDefault;
SelectRect := Rect(
0
,
0
,
0
,
0
);
DrawScreen;
LastSelectRect := Rect(
0
,
0
,
0
,
0
);
lblRect.Caption :=
IntToStr(SelectRect.Left) +
','
+
IntToStr(SelectRect.Top) +
','
+
IntToStr(SelectRect.Right) +
','
+
IntToStr(SelectRect.Bottom);
end
else
Application.Terminate;
end
;
end
;
procedure
TForm1.DrawSelect;
begin
// canvas.Draw(0, 0, ScreenBmp);
lblRect.Caption :=
IntToStr(SelectRect.Left) +
','
+
IntToStr(SelectRect.Top) +
','
+
IntToStr(SelectRect.Right) +
','
+
IntToStr(SelectRect.Bottom);
if
bSelect
then
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := clRed;
if
(LastSelectRect.Left <>
0
)
and
(LastSelectRect.Top <>
0
)
and
(LastSelectRect.Right <>
0
)
and
(LastSelectRect.Bottom <>
0
)
then
begin
Canvas.CopyRect(LastSelectRect, ScreenBmp.Canvas, LastSelectRect);
end
;
Canvas.Rectangle(SelectRect);
LastSelectRect := SelectRect;
end
;
end
;
procedure
TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if
TPanel(Sender).Left =
10
then
begin
TPanel(Sender).Left := Screen.Width - TPanel(Sender).Width -
10
;
end
else
begin
TPanel(Sender).Left :=
10
;
end
;
end
;
procedure
TForm1.FormDblClick(Sender: TObject);
var
xy: TPoint;
begin
GetCursorPos(xy);
if
PtInRect(SelectRect, xy)
then
begin
showmessage(
'ok'
);
end
;
end
;
end
.
源码下载链接：
http://download.csdn.net/source/1769199