unit1.~pas

非常丰富的delphi小程序,相信会对你有帮助

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure CMEraseBkgnd(var message:TWMEraseBKgnd);message WM_ERASEBKGND;
    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);
  private
   Dragging:Boolean;
   PointOrigin:TPoint;
   PointOld:TPoint;
   PointNew:TPoint;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
 Dragging:=False;
 Canvas.Pen.Color:=clBlue;
 Canvas.Pen.Mode:=pmNotXor;
end;

procedure TForm1.CMEraseBkgnd(var message:TWMEraseBKgnd);
begin
 Brush.Style:=bsClear;
 inherited;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 Dragging:=True;
 PointOrigin:=Point(X,Y);
 PointOld:=Point(X,Y);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if Dragging then
  begin
   Canvas.MoveTo(PointOrigin.x,PointOrigin.y);
   Canvas.LineTo(PointOld.x,PointOrigin.y);
   Canvas.LineTo(PointOld.x,PointOld.y);
   Canvas.LineTo(PointOrigin.x,PointOld.y);
   Canvas.LineTo(PointOrigin.x,PointOrigin.y);
   PointNew:=Point(X,Y);
   Canvas.MoveTo(PointOrigin.x,PointOrigin.y);
   Canvas.LineTo(PointNew.x,PointOrigin.y);
   Canvas.LineTo(PointNew.x,PointNew.y);
   Canvas.LineTo(PointOrigin.x,PointNew.y);
   Canvas.LineTo(PointOrigin.x,PointOrigin.y);
   PointOld:=PointNew;
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var DeskTopCanvas:TCanvas;
    BitMap:TBitmap;
    src,dest:TRect;
begin
if Dragging then
begin
   Dragging:=False;
   Canvas.MoveTo(PointOrigin.x,PointOrigin.y);
   Canvas.LineTo(PointOld.x,PointOrigin.y);
   Canvas.LineTo(PointOld.x,PointOld.y);
   Canvas.LineTo(PointOrigin.x,PointOld.y);
   Canvas.LineTo(PointOrigin.x,PointOrigin.y);
   DeskTopCanvas:=TCanvas.Create;
   DeskTopCanvas.Handle:=GetDC(Hwnd_Desktop);
   BitMap:=TBitmap.Create;
   try
    src.Left:=Min(PointOrigin.x,X);
    src.Top:=Min(PointOrigin.y,Y);
    src.Right:=Max(PointOrigin.x,X);
    src.Bottom:=Max(PointOrigin.y,Y);
    dest:=Rect(0,0,abs(X-PointOrigin.x),abs(Y-PointOrigin.y));
    BitMap.Width:=abs(X-PointOrigin.x);
    BitMap.Height:=abs(Y-PointOrigin.y);
    BitMap.Canvas.CopyRect(dest,DeskTopCanvas,src);
    BitMap.SaveToFile('Screen.bmp');
    BitMap.Free;
    DeskTopCanvas.Free;
   except
    ShowMessage('操作错误');
   end;
end;
end;

end.