{

   This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either
  version 2 of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}

//------------------------------------------------------------------------------
//  Apprehend Version  : 4.1
//  Copyright (c) 2005 : Adirondack Software & Graphics
//  Created            : 1-09-1992
//  Last Modification  : 07-26-2005
//  Description        : CaptureTheRect Unit
//------------------------------------------------------------------------------

unit UfrmCaptureRect;

interface

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

type
  TfrmCaptureRect = class ( TForm )
    Timer1: TTimer;
    Timer2: TTimer;
    procedure FormCreate ( Sender: TObject );
    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 );
    procedure FormPaint ( Sender: TObject );
    procedure FormDestroy ( Sender: TObject );
    procedure Timer1Timer ( Sender: TObject );
    procedure FormShow(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);
    procedure FormShortCut(var Msg: TWMKey; var Handled: Boolean);
  public
    function ScreenToBitmapX ( SX: Integer ): Integer;
    function ScreenToBitmapY ( SY: Integer ): Integer;
  private
    { Private declarations }
    X1, Y1, X2, Y2: Integer;
    os: integer;
    frmmagnify:Tfrmmagnify;

    procedure RemoveTheRect;
    procedure DrawTheRect(Canvas:TCanvas);
    procedure WMEraseBkGnd ( var Msg: TWMEraseBkGnd ); message WM_ERASEBKGND;
    function RectIncludesPoint ( const R: TRect; const Pt: TPoint ): Boolean;
    procedure DrawMagnify(x,y:integer;leftdown:boolean);
  public
      { Public declarations }
    fRect: TRect;
    fBmp: TBitmap;
    RectBitmap: TBitmap;
    M: Integer;
  end;

  procedure DoPixelFormatFix (bitmapp: TBitmap);

var
  frmCaptureRect: TfrmCaptureRect;
  Counter: Byte;
  CounterStart: Byte;
  Looper: LongInt;
  ForceMonitorNum : Integer;

implementation
uses Ufunction;

{$R *.DFM}

const BitBltRopMode_Win9x=SRCCOPY;
const BitBltRopMode_WinNT=$40000000 or SRCCOPY;
const BitBltRopMode=$40000000 or SRCCOPY;

procedure DoPixelFormatFix (bitmapp: TBitmap);
begin
  bitmapp.PixelFormat := pf24bit;
//  bitmapp.PixelFormat := pfDevice;
//  bitmapp.PixelFormat := pf32bit;
end;

function GetBitBlt_RopMode() : Integer;
begin
  windows.GetVersion();
  if (Win32Platform=VER_PLATFORM_WIN32_NT) then Result := BitBltRopMode_WinNT
  else Result := BitBltRopMode_Win9x;
end;

{ Animated Rubbanding }
procedure MovingDots ( X, Y: Integer; TheCanvas: TCanvas ); stdcall;
begin
  {$R-}
  Inc ( Looper );
  Counter := Counter shl 1; // Shift the bit left one
  if Counter = 0 then Counter := 1; // If it shifts off left, reset it
  if ( Counter and 224 ) > 0 then // Are any of the left 3 bits set?
    TheCanvas.Pixels [ X, Y ] := clRed // Erase the pixel
  else
    TheCanvas.Pixels [ X, Y ] := clWhite; // Draw the pixel
  {$R+}
end;

{ Animated Rubbanding }
function NormalizeRect ( R: TRect ): TRect;
begin
  // This routine normalizes a rectangle. It makes sure that the Left,Top
  // coords are always above and to the left of the Bottom,Right coords.
  with R do
    if Left > Right then
      if Top > Bottom then
        Result := Rect ( Right, Bottom, Left, Top )
      else
        Result := Rect ( Right, Top, Left, Bottom )
    else
      if Top > Bottom then
        Result := Rect ( Left, Bottom, Right, Top )
      else
        Result := Rect ( Left, Top, Right, Bottom );
end;

{ Animated Rubbanding }
procedure TfrmCaptureRect.RemoveTheRect;
var
  R: TRect;
begin
  R := NormalizeRect ( Rect ( X1, Y1, X2, Y2 ) ); // Rectangle might be flipped
  InflateRect ( R, 1, 1 ); // Make the rectangle 1 pixel larger
  InvalidateRect ( Handle, @R, True ); // Mark the area as invalid
  InflateRect ( R, -2, -2 ); // Now shrink the rectangle 2 pixels
  ValidateRect ( Handle, @R ); // And validate this new rectangle.
  // This leaves a 2 pixel band all the way around
  // the rectangle that will be erased & redrawn
  UpdateWindow ( Handle );
end;

{ Animated Rubbanding }
procedure TfrmCaptureRect.DrawTheRect(Canvas:TCanvas);
begin
  // Determines starting pixel color of Rect
  Counter := CounterStart;

  if (os>=cOsWin95) and (os<=cOsWin2003) then begin
    // Use LineDDA to draw each of the 4 edges of the rectangle
    LineDDA ( X1, Y1, X2, Y1, @MovingDots, LongInt ( Canvas ) );
    LineDDA ( X2, Y1, X2, Y2, @MovingDots, LongInt ( Canvas ) );
    LineDDA ( X2, Y2, X1, Y2, @MovingDots, LongInt ( Canvas ) );
    LineDDA ( X1, Y2, X1, Y1, @MovingDots, LongInt ( Canvas ) );
  end else begin
    Canvas.Pen.Color:=clred;
    Canvas.MoveTo(X1, Y1);
    Canvas.LineTo(X2, Y1);
    Canvas.MoveTo(X2, Y1);
    Canvas.LineTo(X2, Y2);
    Canvas.MoveTo(X2, Y2);
    Canvas.LineTo(X1, Y2);
    Canvas.MoveTo(X1, Y2);
    Canvas.LineTo(X1, Y1);
  end;
end;

procedure TfrmCaptureRect.FormCreate ( Sender: TObject );
var
  ScreenDC: HDC;
  lpPal: PLogPalette;
  P : TPoint;   // Where is the mouse now?
begin
  os:=GetOperatingSystem;
  ForceMonitorNum:=-1;
  //Code added to determine which monitor is being captured, in multi-monitor system.
  //Use whichever monitor the cursor is currently positioned in.
  GetCursorPos ( P );                                   // Where am I?
  if (ForceMonitorNum >=0) and (ForceMonitorNum <= Screen.MonitorCount-1)
    then M := ForceMonitorNum  {Override}
    else M := Screen.MonitorFromPoint ( P, mdNearest ).MonitorNum; // Here I am!  Monitors[M]
  // Setup to capture image
  fBMP := TBitmap.Create;
  DoPixelFormatFix(fBMP);
  //MessageDlg(Format('Debugging!  Monitor: [%d], X:[%d], Y:[%d]',[M,P.X, P.Y]), mtInformation, [mbOK], 0);
  RectBitmap := TBitmap.Create;
  DoPixelFormatFix(RectBitmap);
  fBMP.Width := Screen.Monitors[M].Width;   // Size to active monitor, which may differ from the primary.
  fBMP.Height := Screen.Monitors[M].Height;
  ScreenDC := GetDC ( 0 );
   // do we have a palette device? - Thanks to Joe C. Hecht
  if ( GetDeviceCaps ( ScreenDC, RASTERCAPS ) and RC_PALETTE = RC_PALETTE ) then
  begin
     // allocate memory for a logical palette
    GetMem ( lpPal, Sizeof ( TLOGPALETTE ) + ( 255 * Sizeof ( TPALETTEENTRY ) ) );
     // zero it out to be neat
    FillChar ( lpPal^, Sizeof ( TLOGPALETTE ) + ( 255 * Sizeof ( TPALETTEENTRY ) ), #0 );
     // fill in the palette version
    lpPal^.palVersion := $300;
     // grab the system palette entries
    lpPal^.palNumEntries :=
      GetSystemPaletteEntries ( ScreenDC, 0, 256, lpPal^.palPalEntry );
    if ( lpPal^.PalNumEntries <> 0 ) then
     // create the palette
      fBMP.Palette := CreatePalette ( lpPal^ );
    FreeMem ( lpPal, Sizeof ( TLOGPALETTE ) + ( 255 * Sizeof ( TPALETTEENTRY ) ) );
  end;
  try
    // Copy the screen of monitors[M] onto the bitmap.
    // Screen.Monitors[M].Left,Top will be 0,0 for a single-monitor system.
    // But for dual monitors, you would typically have 1024,0 on second monitor,
    // depending on resolution and placement, of course.
    BitBlt (fBMP.Canvas.handle, 0, 0, Screen.Monitors[M].Width, Screen.Monitors[M].Height, ScreenDC, Screen.Monitors[M].Left, Screen.Monitors[M].Top, GetBitBlt_RopMode() );
  finally
    ReleaseDC ( 0, ScreenDC );
    // Mouse also must be bounded by the current monitor.
    SetBounds ( 0, 0, Screen.Monitors[M].Width, Screen.Monitors[M].Height );
    // Setup Animated Rubberband
    X1 := 0;
    Y1 := 0;
    X2 := 0;
    Y2 := 0;
    Canvas.Pen.Color := clRed;
    Canvas.Brush.Color := clWhite;
    CounterStart := 128;
    Timer1.Interval := 100;
    Timer1.Enabled := True;
    Looper := 0;
  end;

end;

// Upon showing the form, move it to the upper-left of the active monitor.
procedure TfrmCaptureRect.FormShow(Sender: TObject);
var
  size:integer;
begin
  Self.Left := Screen.Monitors[M].Left;
  Self.Top  := Screen.Monitors[M].Top;

  frmmagnify:=Tfrmmagnify.Create(self);
  if Screen.Monitors[M].Width>Screen.Monitors[M].Height then
    size:=Screen.Monitors[M].Height
  else
    size:=Screen.Monitors[M].Width;
  size:=round(size/4.5);
  if size<150 then size:=150;
  frmmagnify.Width:=size;
  frmmagnify.Height:=size;
  frmmagnify.Left:=Screen.Monitors[M].Left+Screen.Monitors[M].Width-frmmagnify.Width-20;
  frmmagnify.Top:=Screen.Monitors[M].Top+Screen.Monitors[M].Height-frmmagnify.Height-20;
  frmmagnify.Show;
end;

procedure TfrmCaptureRect.FormMouseDown ( Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer );
begin
  if ShowHint then
  begin
    Hint := IntToStr ( X ) + ' x ' + IntToStr ( Y ) + ' pixels';
    Application.ActivateHint ( Mouse.CursorPos );
  end;
  RemoveTheRect; // Erase any existing rectangle
  X1 := X; Y1 := Y; X2 := X; Y2 := Y;
  SetRect ( fRect, X, Y, X, Y ); // Set initial rectangle position
  if frmmagnify<>nil then
    frmmagnify.Timer1Timer(nil);
end;

procedure TfrmCaptureRect.DrawMagnify(x,y:integer;leftdown:boolean);
var
  a,b:tbitmap;
  r1:trect;
  w,h,diff:integer;
begin
    if frmmagnify<>nil then begin
     a:=tbitmap.Create;
     b:=tbitmap.Create;
     try
      b.Assign(fBmp);
      if leftdown then begin
        DrawTheRect(b.Canvas);
      end else begin
        b.Canvas.Pen.Color:=clred;
        diff:=5;
        b.Canvas.MoveTo(x-diff,y);
        b.Canvas.LineTo(x+diff,y);
        b.Canvas.MoveTo(x,y-diff);
        b.Canvas.LineTo(x,y+diff);
      end;
      a.Width:=frmmagnify.Width;
      a.Height:=frmmagnify.Height;
      w:=a.Width div 3;
      h:=a.Height div 3;
      r1.Left:=X-(w div 2);
      r1.Top:=Y-(h div 2);
      r1.Right:=r1.Left+w;
      r1.Bottom:=r1.Top+h;
      a.Canvas.CopyRect(rect(0,0,a.Width,a.Height), b.Canvas, r1);
      a.Canvas.Pen.Color:=clblack;
      a.Canvas.Brush.Style:=bsclear;
      a.Canvas.Rectangle(rect(0,0,a.Width,a.Height));
      frmmagnify.Canvas.Draw(0,0,a);

      r1.Left := X1;
      r1.Top := Y1;
      r1.Right := X2;
      r1.Bottom := Y2;
      frmmagnify.Canvas.Brush.Color:=clinfobk;
      frmmagnify.Canvas.Font.Color:=clinfotext;
      frmmagnify.Canvas.TextOut(2,2,
        format('x:%d,y:%d -> x:%d,y:%d (%d,%d)',
          [r1.Left,r1.Top,r1.Right,r1.Bottom,abs(r1.Right-r1.Left),abs(r1.Bottom-r1.Top)])
      );
     finally
       a.Free;
       b.Free;
     end;
    end;
end;

procedure TfrmCaptureRect.FormMouseMove ( Sender: TObject; Shift: TShiftState; X,
  Y: Integer );
var
  HintWidth: Integer;
  HintHeight: Integer;
begin
  if ssLeft in Shift then
  begin
    RemoveTheRect; // Erase any existing rectangle
    X2 := X; Y2 := Y; // Save the new corner where the mouse is
    DrawTheRect(Canvas); // Draw the Rect now... don't wait for the timer!
    fRect.Right := X; // Set the position of the rectangle to capture
    fRect.Bottom := Y;

    DrawMagnify(x,y,true);

    if ShowHint then
    begin
      Hint := IntToStr ( Abs ( fRect.Bottom - fRect.Top ) ) + ' x ' + IntToStr ( Abs ( fRect.Right - fRect.Left ) ) + ' pixels';
      // Get the width and height of the hint window
      HintWidth := ( self.Canvas.TextWidth ( Hint ) );
      HintHeight := ( self.Canvas.TextHeight ( Hint ) );
      // Adjust hint position
      if ( Abs ( X ) > ( Screen.Width - ( HintWidth + 8 ) ) ) then
      begin
        Application.HideHint;
        Update;
      end
      else if ( Abs ( Y ) > ( Screen.Height - ( HintHeight * 2 ) ) ) then
      begin
        Application.HideHint;
        Update;
      end
      else if ( ( ( fRect.Right > fRect.Left ) and ( fRect.Bottom > fRect.Top ) ) ) then
      begin
        Application.ActivateHint ( Point ( Mouse.CursorPos.X, Mouse.CursorPos.Y + HintHeight + 2 ) );
        Update;
      end
      else
      begin
        Application.ActivateHint ( Point ( Max ( fRect.Right, fRect.Left ), Max ( fRect.Bottom, fRect.Top ) + HintHeight + 2 ) );
        Update;
      end;
    end;

  end else begin
    DrawMagnify(x,y,false);
  end;
end;

procedure TfrmCaptureRect.FormMouseUp ( Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer );
begin
  if Button = mbLeft then begin
    if frmmagnify<>nil then
      frmmagnify.Visible:=false;
    Timer2.Enabled:=true;
  end;
end;

procedure TfrmCaptureRect.FormPaint ( Sender: TObject );
begin
  Canvas.Draw ( 0, 0, fBMP );
end;

procedure TfrmCaptureRect.FormDestroy ( Sender: TObject );
begin
  fBMP.Free;
  RectBitmap.Free;
end;

procedure TfrmCaptureRect.WMEraseBkGnd ( var Msg: TWMEraseBkGnd );
begin
  Msg.Result := 1;
end;

function TfrmCaptureRect.RectIncludesPoint ( const R: TRect; const Pt: TPoint ): Boolean;
begin
  Result := ( Pt.X > R.Left ) and ( Pt.X < R.Right ) and
    ( Pt.Y > R.Top ) and ( Pt.Y < R.Bottom );
end;

procedure TfrmCaptureRect.Timer1Timer ( Sender: TObject );
begin
  CounterStart := CounterStart shr 2; // Shl 1 will move rect slower
  if CounterStart = 0 then CounterStart := 128; // If bit is lost, reset it
  DrawTheRect(Canvas); // Draw the rectangle
end;

function TfrmCaptureRect.ScreenToBitmapX ( SX: Integer ): Integer;
begin
  Result := SX-(Screen.Monitors[M].Left + fRect.Left);
end;

function TfrmCaptureRect.ScreenToBitmapY ( SY: Integer ): Integer;
begin
  Result := SY-(Screen.Monitors[M].Top + fRect.Top);
end;

procedure TfrmCaptureRect.Timer2Timer(Sender: TObject);
var
  ScreenDC: HDC;
  Bitmap: TBitmap;
begin
  if (frmmagnify<>nil) and (frmmagnify.Visible) then exit;
  Timer2.Enabled:=false;

    Bitmap := TBitmap.Create;
    DoPixelFormatFix(Bitmap);
    // Set fRect
    fRect.Left := min ( X1, X2 );
    fRect.Top := min ( Y1, Y2 );
    fRect.Right := max ( X1, X2 );
    fRect.Bottom := max ( Y1, Y2 );
    // Exit if improper rectangle drawn
    if ( fRect.Right > fRect.Left ) and ( fRect.Bottom > fRect.Top ) then
    begin
      Bitmap.Width := fRect.Right - fRect.Left;
      Bitmap.Height := fRect.Bottom - fRect.Top;
      RemoveTheRect;
      ScreenDC := GetDC ( 0 );
      try
        // Again, Monitors[M] comes into play on multi-monitor systems.
        // Instead of a 0,0 origin, it may be 1024,0 or 0,768, etc..
        // For a single monitor, Screen.Monitors[M].Left is 0, same for ".Top".
        BitBlt ( Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, ScreenDC, Screen.Monitors[M].Left + fRect.Left, Screen.Monitors[M].Top + fRect.Top, GetBitBlt_RopMode() );
        RectBitmap.Assign ( Bitmap );
        fBmp.Assign ( Bitmap );
      finally
        ReleaseDC ( 0, ScreenDC );
        Bitmap.Free;
      end;
    end; // if
    ModalResult := mrOK;
end;

procedure TfrmCaptureRect.FormShortCut(var Msg: TWMKey;
  var Handled: Boolean);
begin
  if msg.CharCode=vk_escape then
    ModalResult := mrcancel;
end;

end.

