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