delphi 模仿QQ截图

unit UnitCutPic;

interface

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

type
TFrmCutPic = class(TForm)
SaveDPic: TSaveDialog;
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
procedure SnapScreen(a, b, c, d: Integer; Apath: string);
{ Private declarations }
public
{ Public declarations }
end;

var
FrmCutPic: TFrmCutPic;
BeginX,BeginY,Endx,EndY:integer;//全局变量 记录鼠标按下时的X,Y坐标
IsPoint:Boolean;
point:Tpoint;
Arect:TRect;
implementation

{$R *.dfm}

procedure TFrmCutPic.SnapScreen(a,b,c,d:Integer;Apath:string); //任意区域截图,参数为截图坐标
var
bmpscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
sourceRect, destRect: TRect;
begin
dc:=getdc(0);
fullscreencanvas:=Tcanvas.Create;
fullscreencanvas.Handle:=dc;
bmpscreen:=Tbitmap.create;
bmpscreen.Width :=c-a;
bmpscreen.Height :=d-b;
sourcerect:=Rect(0,0,c-a ,d-b );
destrect:= Rect(a,b,c,d);
bmpscreen.Canvas.CopyRect(sourcerect,fullscreenCanvas,destrect);
bmpscreen.SaveToFile(Apath);
FullscreenCanvas.Free;
bmpscreen.Free;
ReleaseDC(0, DC);
end;

procedure TFrmCutPic.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ssright in shift then Self.Close;
if (IsPoint=True) and (ssleft in shift) and (ssDouble in Shift)then
begin
GetCursorPos(point);
if PtInRect(Arect,point)=True then
begin
SnapScreen(Arect.Left,Arect.Top,Arect.Right,Arect.Bottom,ExtractFilePath(Application.ExeName)+'\Cut.bmp');
if not SaveDPic.Execute then
begin
DeleteFile(ExtractFilePath(Application.ExeName)+'\Cut.bmp');
Exit;
end;
CopyFile(PChar(ExtractFilePath(Application.ExeName)+'\Cut.bmp'),PChar(SaveDPic.FileName),False);
DeleteFile(ExtractFilePath(Application.ExeName)+'\Cut.bmp');
Self.Close;
end;
end;
BeginX:=X;BeginY:=Y;//记录鼠标按下时的X,Y坐标
end;

procedure TFrmCutPic.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
GetCursorPos(point);
if (PtInRect(Arect,point)=True) then
Cursor:=crSizeAll
else
Cursor:=crCross;


//下面代码演示的是背景为纯色时的选取框.
//选取的范围可记录在一个TRECT变量里.具体情况视要求而定.
//当背影为图形时..可以把注释1之间的代码替换为重绘背景的代码
if ssLeft in shift then//判断鼠标左键是下按着.
begin
Canvas.Brush.Color:=RGB(255,255,255);
Canvas.Brush.Style:=bsSolid;
Canvas.FillRect(RECT(0,0,width,height));
Canvas.Brush.Style:=bsClear;
Canvas.Pen.Style:=psDot;
Canvas.Pen.Width:=2;
Canvas.Pen.Color:=clBlue;
Canvas.Rectangle(BeginX,BeginY,X,Y);
Arect.Left:=BeginX;
Arect.Top:=BeginY;
Arect.Right:=x;
Arect.Bottom:=y;
endx:=x;
endy:=y;
IsPoint:=True;
end;
end;

procedure TFrmCutPic.FormKeyPress(Sender: TObject; var Key: Char);
begin
if key = #27 then application.terminate;
end;

end.