RealICQClient/CopyScreen/CopyScreenFrm.pas

unit CopyScreenFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, JPeg, AppEvnts, StdCtrls, Menus, ExtDlgs, StrUtils,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;

type
  TScreenState = (msDefault,msDrag,msSelected);
  TDragState = (dsNone,
    dsLeftTop,
    dsTop,
    dsRightTop,
    dsRight,
    dsRightBottom,
    dsBottom,
    dsLeftBottom,
    dsLeft,
    dsClient);

  TCopyScreenForm = class(TForm)
    ImgScreen: TImage;
    PnlInfo: TPanel;
    LblRGB: TLabel;
    LblActionInfo: TLabel;
    LblCancelInfo: TLabel;
    ApplicationEvents1: TApplicationEvents;
    Label1: TLabel;
    SavePictureDialog: TSavePictureDialog;
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure PnlInfoMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ImgScreenMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ImgScreenMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImgScreenMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    procedure ImgScreenDblClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
    DX,DY,RectLeft,RectTop,RectBottom,RectRight:Integer;
    MouseIsDown,
    Trace:Boolean;
    ScreenState:TScreenState;
    FDragState: TDragState;
    procedure Cancel;
    procedure SendImg;
    procedure SaveImage;
  public
  end;
  
  procedure ShowCopyScreenForm;

var
  CopyScreenForm: TCopyScreenForm;
  ScreenFileNO: Integer;
  ScreenFileName: String;

implementation

{$R *.dfm}

procedure ShowCopyScreenForm;
var
  FullScreen: Tbitmap;
  FullScreenCanvas: TCanvas;
  DC: HDC;
begin
  FullScreen := TBitmap.Create;      //创建一个BITMAP来存放图象
  try
    FullScreen.Width := Screen.width;
    FullScreen.Height := Screen.Height;
    DC := GetDC (0);  //取得屏幕的 DC，参数0指的是屏幕
    FullScreenCanvas := TCanvas.Create; //创建一个CANVAS对象
    FullScreenCanvas.Handle := DC;

    FullScreen.Canvas.CopyRect
      (Rect (0, 0, Screen.Width, Screen.Height), FullScreenCanvas,
      Rect (0, 0, Screen.Width, Screen.Height));
            //把整个屏幕复制到BITMAP中
    FullScreenCanvas.Free;          //释放CANVAS对象
    ReleaseDC (0, DC);              //释放DC

    ScreenFileName := '';
    CopyScreenForm := TCopyScreenForm.Create(nil);
    try
      CopyScreenForm.ImgScreen.picture.Bitmap := fullscreen;//拷贝下的图象赋给IMAGE对象
      CopyScreenForm.Width := FullScreen.Width;
      CopyScreenForm.Height := FullScreen.Height;
    finally
      CopyScreenForm.ShowModal;
    end;
  finally
    FullScreen.free;
    CopyScreenForm.Free;
  end;
end;

//------------------------------------------------------------------------------
procedure DrawBorder(Canvas: TCanvas; RectLeft, RectTop, RectRight, RectBottom: Integer);
begin
  with Canvas do
  begin
    //左上角点
    Rectangle(RectLeft - 1, RectTop - 1, RectLeft + 2, RectTop + 2);
    Pixels[RectLeft, RectTop] :=  not Pixels[RectLeft, RectTop];
    
    //右上角点
    Rectangle(RectRight - 1, RectTop - 1, RectRight + 2, RectTop + 2);
    Pixels[RectRight, RectTop] :=  not Pixels[RectRight, RectTop];

    //左下角点
    Rectangle(RectLeft - 1, RectBottom - 1, RectLeft + 2, RectBottom + 2);
    Pixels[RectLeft, RectBottom] :=  not Pixels[RectLeft, RectBottom];

    //右下角点
    Rectangle(RectRight - 1, RectBottom - 1, RectRight + 2, RectBottom + 2);
    Pixels[RectRight, RectBottom] :=  not Pixels[RectRight, RectBottom];

    //上中点
    MoveTo(RectLeft + 2, RectTop);
    LineTo(RectLeft + (RectRight - RectLeft) div 2 - 1, RectTop);
    Rectangle(RectLeft + (RectRight - RectLeft) div 2 - 1, RectTop - 1, RectLeft + (RectRight - RectLeft) div 2 + 2, RectTop + 2);
    Pixels[RectLeft + (RectRight - RectLeft) div 2, RectTop] :=  not Pixels[RectLeft + (RectRight - RectLeft) div 2, RectTop];
    MoveTo(RectLeft + (RectRight - RectLeft) div 2 + 2, RectTop);
    LineTo(RectRight - 1, RectTop);

    //右中点
    MoveTo(RectRight, RectTop + 2);
    LineTo(RectRight, RectTop + (RectBottom - RectTop) div 2 - 1);
    Rectangle(RectRight - 1, RectTop + (RectBottom - RectTop) div 2 - 1, RectRight + 2, RectTop + (RectBottom - RectTop) div 2 + 2);
    Pixels[RectRight, RectTop + (RectBottom - RectTop) div 2] :=  not Pixels[RectRight, RectTop + (RectBottom - RectTop) div 2];
    MoveTo(RectRight, RectTop + (RectBottom - RectTop) div 2 + 2);
    LineTo(RectRight, RectBottom - 1);

    //下中点
    MoveTo(RectLeft + (RectRight - RectLeft) div 2 + 2, RectBottom);
    LineTo(RectRight - 1, RectBottom);
    Rectangle(RectLeft + (RectRight - RectLeft) div 2 - 1, RectBottom - 1, RectLeft + (RectRight - RectLeft) div 2 + 2, RectBottom + 2);
    Pixels[RectLeft + (RectRight - RectLeft) div 2, RectBottom] :=  not Pixels[RectLeft, RectBottom];
    MoveTo(RectLeft + (RectRight - RectLeft) div 2 - 2, RectBottom);
    LineTo(RectLeft + 1, RectBottom);

    //左中点
    MoveTo(RectLeft, RectTop + 2);
    LineTo(RectLeft, RectTop + (RectBottom - RectTop) div 2 - 1);
    Rectangle(RectLeft - 1, RectTop + (RectBottom - RectTop) div 2 - 1, RectLeft + 2, RectTop + (RectBottom - RectTop) div 2 + 2);
    Pixels[RectLeft, RectTop + (RectBottom - RectTop) div 2] :=  not Pixels[RectLeft, RectTop + (RectBottom - RectTop) div 2];
    MoveTo(RectLeft, RectTop + (RectBottom - RectTop) div 2 + 2);
    LineTo(RectLeft, RectBottom - 1);
   end;
end;
//------------------------------------------------------------------------------
procedure TCopyScreenForm.SendImg;
var
  newbitmap:TBitmap;
  newjpg:TJPegImage;
  TempInt:Integer;
  FileNameStart: String;
  TempJPegFile: array[0..MAX_PATH] of char;
begin
  if ScreenState=msSelected then
  begin
    if RectLeft > RectRight then
    begin
      TempInt := RectLeft;
      RectLeft := RectRight;
      RectRight := TempInt;
    end;

    if RectTop > RectBottom then
    begin
      TempInt := RectTop;
      RectTop := RectBottom;
      RectBottom := TempInt;
    end;

    newbitmap := Tbitmap.create;
    newbitmap.width := RectRight-RectLeft;
    newbitmap.height := RectBottom-RectTop;
    if Trace then DrawBorder(ImgScreen.Canvas, RectLeft,RectTop,RectRight,RectBottom);

    newbitmap.Canvas.CopyRect(Rect(0, 0, newbitmap.width, newbitmap.height),ImgScreen.canvas,Rect (RectLeft, RectTop,RectRight,RectBottom)); //拷贝
    newjpg:=TJPegImage.Create;
    newjpg.Assign(newbitmap);
    newjpg.CompressionQuality := 90;
    newjpg.Compress;

    GetTempPath(MAX_PATH, TempJPegFile);
    GetTempFileName(TempJPegFile,
    PChar(Copy(FileNameStart, Length(FileNameStart) - 3, 3)),
    GetTickCount,
    TempJPegFile);

    ScreenFileNO := GetTickCount();
    ScreenFileName := ExtractFilePath(TempJPegFile) + IntToStr(ScreenFileNO) + '.JPG';
    newjpg.SaveToFile(ScreenFileName);
    newjpg.Free;
    newbitmap.free;
    Close;
  end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.FormShow(Sender: TObject);
begin
    ScreenState := msDefault;
    MouseIsDown := False;
    Trace := False;
    RectLeft := -1;
    RectTop := -1;
    RectBottom := -1;
    RectRight := -1;
    ImgScreen.Canvas.Pen.mode := pmnot; //笔的模式为取反
    ImgScreen.canvas.pen.color := clBlue; 
    ImgScreen.canvas.pen.Width := 1;
    ImgScreen.canvas.brush.Style := bsclear; //空白刷子end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True;
  FDragState := dsNone;
end;

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

//------------------------------------------------------------------------------
procedure TCopyScreenForm.Cancel;
begin
  if ScreenState = msDefault then
    Close
  else
  begin
    if Trace then DrawBorder(ImgScreen.Canvas, RectLeft,RectTop,RectRight,RectBottom);
    Trace := False;
    ScreenState := msDefault;
    LblActionInfo.Caption := '按住鼠标左键不放选择截取范围';
    LblCancelInfo.Caption := '按鼠标右键退出';
    exit;
  end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.PnlInfoMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if PnlInfo.Left = 8 then
    PnlInfo.Left := Screen.Width - 8 - PnlInfo.Width
  else
    PnlInfo.Left := 8;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.ImgScreenMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
var
  R,G,B:Integer;
  OldLeft, OldTop, OldRight, OldBottom: Integer;
begin
  if (X > PnlInfo.Left) and ( X < PnlInfo.Left + PnlInfo.Width) and ( Y > PnlInfo.Top) and ( Y < PnlInfo.Top + PnlInfo.Height) then
  begin
    PnlInfoMouseMove(Sender, Shift, X, Y);
  end;

  if (ScreenState=msSelected) then
  begin
    if not MouseIsDown then
    begin
      if (X >= RectLeft - 3) and (X <= RectRight + 3) and (Y >= RectTop - 3) and (Y <= RectBottom + 3) then
      begin
        if (X < RectLeft + 3) and (Y < RectTop + 3) then
        begin
          ImgScreen.Cursor := crSizeNWSE; //左上角
          FDragState := dsLeftTop;
        end
        else if (X < RectLeft + 3) and (Y > RectBottom - 3) then
        begin
          ImgScreen.Cursor := crSizeNESW; //左下角
          FDragState := dsLeftBottom;
        end
        else if (X > RectRight - 3) and (Y < RectTop + 3) then
        begin
          ImgScreen.Cursor := crSizeNESW; //右上角
          FDragState := dsRightTop;
        end
        else if (X > RectRight - 3) and (Y > RectBottom - 3) then
        begin
          ImgScreen.Cursor := crSizeNWSE; //右下角
          FDragState := dsRightBottom;
        end
        else if (X < RectLeft + 3)then
        begin
          ImgScreen.Cursor := crSizeWE;  // 左边
          FDragState := dsLeft;
        end
        else if (X > RectRight - 3)then
        begin
          ImgScreen.Cursor := crSizeWE; //右边
          FDragState := dsRight;
        end
        else if (Y < RectTop + 3)then
        begin
          ImgScreen.Cursor := crSizeNS;  // 上边
          FDragState := dsTop;
        end
        else if (Y > RectBottom - 3)then
        begin
          ImgScreen.Cursor := crSizeNS; //下边
          FDragState := dsBottom;
        end
        else
        begin
          ImgScreen.Cursor := crSizeAll;
          FDragState := dsClient;
        end;
      end
      else
      begin
        FDragState := dsNone;
        ImgScreen.Cursor := crDefault;
      end;
    end
    else
    begin
      if FDragState <> dsNone then
      begin
        DrawBorder(ImgScreen.Canvas, RectLeft, RectTop, RectRight, RectBottom);
        OldLeft := RectLeft;
        OldTop := RectTop;  
        OldRight := RectRight;
        OldBottom := RectBottom;  
        case FDragState of
          dsLeftTop:
            begin
              RectLeft := RectLeft + (X - DX);
              RectTop := RectTop + (Y - DY);
            end;
          dsTop:
            begin
              RectTop := RectTop + (Y - DY);
            end;
          dsRightTop:
            begin
              RectRight := RectRight + (X - DX);
              RectTop := RectTop + (Y - DY);
            end;
          dsRight:
            begin
              RectRight := RectRight + (X - DX);
            end;
          dsRightBottom:
            begin
              RectRight := RectRight + (X - DX);
              RectBottom := RectBottom + (Y - DY);
            end;
          dsBottom:
            begin
              RectBottom := RectBottom + (Y - DY);
            end;
          dsLeftBottom:
            begin
              RectLeft := RectLeft + (X - DX);
              RectBottom := RectBottom + (Y - DY);
            end;
          dsLeft:
            begin
              RectLeft := RectLeft + (X - DX);
            end;
          dsClient:
            begin
              RectLeft := RectLeft + (X - DX);
              RectRight := RectRight + (X - DX);
              RectTop := RectTop + (Y - DY);
              RectBottom := RectBottom + (Y - DY);
            end;
        end;

        if RectLeft < 0 then RectLeft := 0;
        if RectTop < 0 then RectTop := 0;
        if RectRight > Width then RectRight := Width;
        if RectBottom > Height then RectBottom := Height;

        if RectLeft + 10 > RectRight then
        begin
          if (FDragState = dsLeft) or
             (FDragState = dsLeftBottom) or
             (FDragState = dsLeftTop) then
          begin
            RectLeft := RectRight - 10;
            RectRight := OldRight;
          end
          else
          begin
            RectRight := RectLeft + 10;
            RectLeft := OldLeft;
          end;
          X := DX;
        end;
        if RectTop + 10 > RectBottom then
        begin
          if (FDragState = dsTop) or
             (FDragState = dsLeftTop) or
             (FDragState = dsRightTop) then
          begin
            RectTop := RectBottom - 10;
            RectBottom := OldBottom;
          end
          else
          begin
            RectBottom := RectTop + 10;
            RectTop := OldTop;
          end;
          Y := DY;
        end;

        DrawBorder(ImgScreen.Canvas, RectLeft, RectTop, RectRight, RectBottom);
        DX := X;
        DY := Y;
      end;
    end;
  end
  else
  begin
    ImgScreen.Cursor := crCross;
  end;

  if (ScreenState = msDrag) and MouseIsDown then
  begin
    if Trace then DrawBorder(ImgScreen.Canvas, RectLeft, RectTop, RectRight, RectBottom);
    RectRight := X;
    RectBottom := Y;
    DrawBorder(ImgScreen.Canvas, RectLeft, RectTop, RectRight, RectBottom);
    Trace := True;
  end;

  if ((ImgScreen.Cursor = crCross) or (ImgScreen.Cursor = crDefault)) and (ScreenState <> msDrag) then
  begin
    R:=getRvalue(ImgScreen.Canvas.Pixels[X, Y]);
    G:=getGvalue(ImgScreen.Canvas.Pixels[X, Y]);
    B:=getBvalue(ImgScreen.Canvas.Pixels[X, Y]);
    LblRGB.Caption:='当前像素RGB值（'+IntToStr(R)+'、'+IntToStr(G)+'、'+IntToStr(B)+'）';
  end
  else
  begin
    LblRGB.Caption := Format('当前范围[%d,%d,%d,%d], 大小: %d*%d', [RectLeft, RectTop, RectRight, RectBottom, RectRight - RectLeft, RectBottom - RectTop]);
  end;
  LblRGB.Update;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.ImgScreenMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbRight then
  begin
    Cancel;
    Exit;
  end;

  if (ScreenState = msSelected) and (ImgScreen.Cursor <> crDefault) then
  begin
    MouseIsDown:=True;
    DX:=X;
    DY:=Y;
  end;

  if ScreenState <> msDefault then exit;
  if Trace then DrawBorder(ImgScreen.Canvas, RectLeft,RectTop,RectRight,RectBottom);
  MouseIsDown:=True;
  Trace:=False;
  ScreenState:=msDrag;
  RectLeft:=X;
  RectTop:=Y;
  RectRight:=X;
  RectBottom:=Y;
  LblActionInfo.Caption:='松开鼠标左键以确定最终截取范围';
  LblCancelInfo.Caption:='按鼠标右键取消当前选区';
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.ImgScreenMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  iTemp: Integer;
begin
    MouseIsDown:=False;
    if ScreenState = msDrag then
    begin
      LblActionInfo.Caption := '按空格/回车/双击左键确定当前选区的图像';
      LblCancelInfo.Caption := '按鼠标右键取消当前选区，F5 = 另存为图像文件...';
      ScreenState := msSelected;
      DrawBorder(ImgScreen.Canvas, RectLeft, RectTop, RectRight, RectBottom);
      if RectLeft > RectRight then
      begin
        iTemp := RectLeft;
        RectLeft := RectRight;
        RectRight := iTemp;  
      end;
      if RectTop > RectBottom then
      begin
        iTemp := RectTop;
        RectTop := RectBottom;
        RectBottom := iTemp;  
      end;
      DrawBorder(ImgScreen.Canvas, RectLeft, RectTop, RectRight, RectBottom);
    end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.SaveImage;
var
  newbitmap:TBitmap;
begin
  newbitmap := Tbitmap.create;
  try
    newbitmap.width := RectRight-RectLeft;
    newbitmap.height := RectBottom-RectTop;
    if Trace then DrawBorder(ImgScreen.Canvas, RectLeft,RectTop,RectRight,RectBottom);

    newbitmap.Canvas.CopyRect(Rect(0, 0, newbitmap.width, newbitmap.height),
      ImgScreen.canvas,
      Rect(RectLeft, RectTop,RectRight,RectBottom)); //拷贝

    SavePictureDialog.FileName := 'SC' + IntToStr(GetTickCount) + '.BMP';
    if SavePictureDialog.Execute then
    begin
      if FileExists(SavePictureDialog.FileName) then
      begin
        DeleteFile(SavePictureDialog.FileName);
      end;
      newbitmap.SaveToFile(SavePictureDialog.FileName);
    end;
  finally
    newbitmap.Free;
    if Trace then DrawBorder(ImgScreen.Canvas, RectLeft,RectTop,RectRight,RectBottom);
  end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if Msg.message = WM_KEYDOWN then
  begin
    if Msg.wParam = 27 then
    begin
      Cancel;
    end;

    if (Msg.wParam = 32) or (Msg.wParam = 13) then
    begin
      if ScreenState = msSelected then
      begin
        if ((RectRight - RectLeft) > 5) or ((RectBottom - RectTop) > 5) then
          SendImg
        else
        begin
          Trace := False;
          Cancel;
        end;
      end;
      Handled := True;
    end;

    if (Msg.wParam = 116) then
    begin
      if ScreenState = msSelected then
      begin
        if ((RectRight - RectLeft) > 5) or ((RectBottom - RectTop) > 5) then
          SaveImage;
      end;
      Handled := True;
    end;
    
  end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.ImgScreenDblClick(Sender: TObject);
begin
  if ScreenState = msSelected then
  begin
    if ((RectRight - RectLeft) > 5) or ((RectBottom - RectTop) > 5) then
      SendImg
    else
    begin
      Trace := False;
      Cancel;
    end;
  end;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caFree;
  CopyScreenForm := nil;
end;

//------------------------------------------------------------------------------
procedure TCopyScreenForm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  Hide;
end;

end.