copyscreen.pas

絮语2007视频聊天软件源程序.仅供参考

unit copyscreen;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls,jpeg,clipbrd, StdCtrls;

type
  Tcopy_screen = class(TForm)
    Image1: TImage;
    Label1: TLabel;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image1DblClick(Sender: TObject);
  private
    status_compile,copy_compile:boolean;
    newx,newy,oldx,oldy,w,h: Integer;
    procedure refresh_image;
    { Private declarations }
  public
    copytofile:string;
    { Public declarations }
  end;

implementation
uses udpcores,shareunit;
{$R *.DFM}

procedure Tcopy_screen.Image1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if button=mbleft then
if not copy_compile then
  begin
  status_compile:=true;
  copy_compile:=false;
  newx := x; newy := y;
  oldx := x; oldy := y;
  end;
end;

procedure Tcopy_screen.refresh_image;
var
  FullscreenCanvas : TCanvas;
  DC : HDC;
begin
DC:=GetDC(0);//取得屏幕的DC，参数0指的是屏幕
FullscreenCanvas := TCanvas.Create;//创建一个CANVAS对象
try
FullscreenCanvas.Handle := DC;
image1.Width:=screen.width;
image1.Height:=screen.Height;
image1.Canvas.CopyRect
(Rect(0,0,Screen.Width,Screen.Height),FullScreenCanvas,
  Rect(0,0,Screen.Width,Screen.Height));
image1.Invalidate;
finally
FullScreenCanvas.Free;//释放CANVAS对象
ReleaseDC(0,DC);//释放DC
end;
end;

procedure Tcopy_screen.FormCreate(Sender: TObject);
begin
refresh_image;
end;

procedure Tcopy_screen.FormShow(Sender: TObject);
begin
image1.left:=0; image1.top:=0;
windowstate:=wsMaximized;
Image1.Canvas.Pen.mode:=pmnot;//笔的模式为取反
Image1.canvas.pen.color := clblack;//笔为黑色
Image1.canvas.brush.Style := bsclear;//空白刷子
image1.Canvas.Lock;
end;

procedure Tcopy_screen.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
if button=mbleft then
if not copy_compile then
  begin
  status_compile:=false;
  copy_compile:=true;
  end;
  
if button=mbRight then
if copy_compile then
  begin
  label1.caption:='';
  status_compile:=false;
  copy_compile:=false;
  with Image1.canvas do
   rectangle(newx,newy,oldx,oldy);
  end else close;
end;

procedure Tcopy_screen.Image1MouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
if status_compile then//是否在追踪鼠标？
  begin
   with Image1.canvas do
     begin
     rectangle(newx,newy,oldx,oldy);
     Rectangle(newx,newy,x,y);
     oldx:=x;oldy:=y;
     end;
  label1.Left:=x+1;
  label1.top:=y+1;
  label1.caption:='图片大小:'+inttostr(abs(x-newx))+':'+inttostr(abs(y-newy));
  end;
end;

procedure Tcopy_screen.Image1DblClick(Sender: TObject);
var swp:integer;
    bitmap:tbitmap;
    tmpstream:Tmemorystream;
begin
if oldx<newx then begin swp:=newx;newx:=oldx;oldx:=swp; end;
if oldy<newy then begin swp:=newy;newy:=oldy;oldy:=swp; end;
w:=oldx-newx;h:=oldy-newy;
if (w<=0)or(h<=0) then exit;
if copy_compile then
  begin
  label1.caption:='';
  with Image1.canvas do
   rectangle(newx,newy,oldx,oldy);
  with tjpegimage.Create do
    try
      tmpstream:=Tmemorystream.create;
      bitmap:=tbitmap.Create;
      try
      bitmap.width:=w;bitmap.height:=h;
      bitmap.canvas.CopyRect(rect(0,0,w,h),image1.canvas,rect(newx,newy,oldx,oldy));
      assign(bitmap);
      clipboard.Assign(bitmap);

      CompressionQuality:=65;
      compress;
      savetostream(tmpstream);
      copytofile:=extractfilepath(application_name)+'images\{'+md5encode(tmpstream)+'}.jpg';
      tmpstream.savetofile(copytofile);
      finally
      bitmap.free;
      tmpstream.free;
      end;
    finally
    free;
    end;
  close;
  end;
end;

end.