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:=#ffffff;
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.