capturescreen.pas

截屏源码。非传统的截图程序

unit CaptureScreen;

interface

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

type
  TCaptureMode = (CMWindow, CMAutoRect,CMManualRect);

  TCaptureForm = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormDeactivate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormDblClick(Sender: TObject);
  private
    { Private declarations }
    DrawIng: Boolean;
    StartPoint: TPoint;
    EndPoint: TPoint;
    FBitMap:TBitMap;
    FRect:TRect;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  public
    { Public declarations }
    OK : boolean;
    CaptureMode: TCaptureMode;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CaptureWindow(WindowsPos: TPoint);
    procedure CaptureRect(R: TRect);
    procedure ClearRect(R: TRect);
    function  SamePoint(R: TRect): Boolean;
  end;

var
  CaptureForm: TCaptureForm;

function WBCaptureScreen(Mode: TCaptureMode;var pBitmap:TBitmap;pLeft:integer=0;pTop:integer=0;pRight:integer=0;pBottom:integer=0): Boolean;

implementation

{$R *.dfm}

{ TCaptureForm }

function WBCaptureScreen(Mode: TCaptureMode;var pBitmap:TBitmap;pLeft:integer=0;pTop:integer=0;pRight:integer=0;pBottom:integer=0): Boolean;
begin

  with TCaptureForm.Create(Application) do
  try
    OK := false;
    CaptureMode := Mode;
    FBitmap:=pBitmap ;
    FRect.Left:=pLeft;
    FRect.Top:=pTop;
    FRect.Right:=pRight;
    FRect.Bottom:=pBottom;
    Showmodal;
  finally
    Result := OK;
    Free;
  end;
end;

procedure TCaptureForm.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TCaptureForm.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  SetBkMode(handle, TRANSPARENT);
  Message.Result := 1;
end;

procedure TCaptureForm.FormClick(Sender: TObject);
begin
   exit;
  if not DrawIng then
  begin
    ClearRect(Rect(StartPoint, EndPoint));
    StartPoint.X := 0;
    StartPoint.Y := 0;
    EndPoint.X := 0;
    EndPoint.Y := 0;
  end;

  DrawIng := false;
end;

procedure TCaptureForm.FormCreate(Sender: TObject);
begin
  CaptureMode := CMWindow;
  DrawIng := False;
  StartPoint.X := 0;
  StartPoint.Y := 0;
  EndPoint.X := 0;
  EndPoint.Y := 0;
end;

procedure TCaptureForm.FormMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  if CaptureMode <> CMManualRect then
    Exit;
  if DrawIng then
  begin
    if not drawing then exit;
    canvas.Pen.Style := psDash;
    canvas.Pen.Mode := pmNotXor;
    canvas.Brush.Style := bsClear;
    canvas.Rectangle(Rect(StartPoint, EndPoint));
    EndPoint := Point(X, Y);
    canvas.Rectangle(Rect(StartPoint, EndPoint));
  end;
end;

procedure TCaptureForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  case CaptureMode of
    CMWindow:
      begin
        CaptureWindow(Point(x, y));
      end;
    CMManualRect:
      begin
        if SamePoint(Rect(StartPoint, EndPoint)) then
        begin
          ClearRect(Rect(StartPoint, EndPoint));
          DrawIng := True;
          StartPoint := Point(x, y);
          EndPoint := StartPoint;
        end;
      end;
    CMAutoRect:
      begin
         CaptureRect(FRect);
      end;
  end;
end;

procedure TCaptureForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  L, T, R, B: Integer;
begin
  if CaptureMode <> CMManualRect then
    Exit;
  if DrawIng then
  begin

    if StartPoint.X > X then
    begin
      L := X;
      R := StartPoint.X;
    end
    else
    begin
      R := X;
      L := StartPoint.X;
    end;

    if StartPoint.Y > Y then
    begin
      T := Y;
      B := StartPoint.Y;
    end
    else
    begin
      B := Y;
      T := StartPoint.Y;
    end;

    CaptureRect(Rect(L, T, R, B));
  end;

end;

procedure TCaptureForm.CaptureRect(R: TRect);
var
  bmp: TBitmap;
  dc: HDC;
begin
  FBitMap.Width := R.Right - R.Left;
  FBitMap.Height := R.Bottom - R.Top;
  BitBlt(FBitMap.Canvas.Handle, 0, 0, FBitMap.Width, FBitMap.Height, Canvas.Handle,
         R.Left, R.Top, SRCCOPY);
  drawing := false;
  OK := true;
  Close;
end;

procedure TCaptureForm.CaptureWindow(WindowsPos: TPoint);
var
  bmpscr: TBitmap;
  bmp: TBitmap;
  dc: HDC;
  R: Trect;
  H: THandle;
begin
  bmpScr := TBitmap.Create;
  try
    bmpScr.Width := Width;
    bmpScr.Height := Height;
    BitBlt(BmpScr.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle,
      0, 0, SRCCOPY); {}

    hide;
    H := WindowFromPoint(WindowsPos);
    while GetParent(H) > 0 do
      H := GetParent(H);
    GetWindowRect(H, R);
    if R.Left < 0 then R.Left := 0;
    if R.Top < 0 then R.Top := 0;
    if R.Right > Self.Width then R.Right := Self.Width;
    if R.Bottom > Self.Height then R.Bottom := Self.Height;
    FBitMap.Width := r.Right - r.Left;
    FBitMap.Height := r.Bottom - r.Top;

    BitBlt(FBitMap.Canvas.Handle, 0, 0, FBitMap.Width, FBitMap.Height, BmpScr.Canvas.Handle,
      r.Left, r.Top, SRCCOPY); {}
 finally
  bmpscr.Free;
 end;
  DrawIng := False;
  Close;
end;

procedure TCaptureForm.ClearRect(R: TRect);
begin
  if SamePoint(R) then exit;
  
    canvas.Pen.Style := psDash;
    canvas.Pen.Mode := pmNotXor;
    canvas.Brush.Style := bsClear;
    canvas.Rectangle(R);
end;

procedure TCaptureForm.FormDblClick(Sender: TObject);
begin
  if not SamePoint(Rect(StartPoint, EndPoint)) then
     CaptureRect(Rect(StartPoint, EndPoint));
  close;
end;

procedure TCaptureForm.FormDeactivate(Sender: TObject);
begin
  DrawIng := False;
  Close;
end;

procedure TCaptureForm.FormDestroy(Sender: TObject);
begin
//
end;

procedure TCaptureForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if key = 27 then  
    Close;
end;

procedure TCaptureForm.FormShow(Sender: TObject);
var
  i: Integer;
begin
  Self.Width := 0;
  Self.Height := 0;
  self.Top := 0;
  self.Left := 0;
  
  for i := 0 to Screen.MonitorCount - 1 do
  begin
    Self.Width := Self.Width + Screen.Monitors[i].Width;
    if Screen.Height > Self.Height then
      Self.Height := Screen.Height;

    if Screen.Monitors[i].Left < self.Left then
       self.Left := Screen.Monitors[i].Left;

  end;
  SetWindowPos(handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
end;

function TCaptureForm.SamePoint(R: TRect): Boolean;
begin
  Result := (R.Left = R.Right) And (R.Top = R.Bottom); 
end;

end.