capturetherect.pas

Apprehend Screen Capture Component Version 4.2 A non-visible component to capture images. Freeware w

{----------------------------------------------------------------------------
| Library: ASG Screen Capture ( Apprehend 2001 )
| Adirondack Software & Graphics Capture RectForm Unit
| for Delphi 5
| (C) Copyright Adirondack Software & Graphics 1996-2001
|
| Module: CaptureRect
|
| Description: TASGCapture Capture Rect Form.
|
| Known Problems: None
|
| History: Previously developed as an application in the 1990's.
|          July 4, 2000. William Miller, first BETA version
|          July 13, 2000. William Miller, 2nd BETA version
|          Changed CaptureRect.Pas to paint the rubberband
|          on the form instead of a TImage to eliminate screen flicker.
|          September 21, 2000. William Miller, Version 1.0
|---------------------------------------------------------------------------}

unit CaptureTheRect;

interface

uses Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  ExtCtrls;
type
  TCaptureRectForm = class ( TForm )
    Timer1: 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 );
  private
      { Private declarations }
    X1, Y1, X2, Y2: Integer;
    procedure RemoveTheRect;
    procedure DrawTheRect;
    procedure WMEraseBkGnd ( var Msg: TWMEraseBkGnd );message WM_ERASEBKGND;
  public
      { Public declarations }
    fRect: TRect;
    fBmp: TBitmap;
    RectBitmap: TBitmap;
  end;

var
  CaptureRectForm: TCaptureRectForm;
  Counter: Byte;
  CounterStart: Byte;
  Looper: LongInt;

implementation

uses ASGCapture;

{$R *.DFM}

{ Animated Rubbanding }
{--------------------------------------------------------------------------}
procedure MovingDots ( X, Y: Integer;TheCanvas: TCanvas );stdcall;
begin
  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
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 TCaptureRectForm.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 TCaptureRectForm.DrawTheRect;
begin
  // Determines starting pixel color of Rect
  Counter := CounterStart;
  // 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;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.FormCreate ( Sender: TObject );
var
  ScreenDC: HDC;
  lpPal: PLogPalette;
begin
   // Setup to capture image
  fBMP := TBitmap.Create;
  RectBitmap := TBitmap.Create;
  fBMP.Width := Screen.Width;
  fBMP.Height := Screen.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
    BitBlt ( fBMP.Canvas.handle, 0, 0, Screen.Width, Screen.Height, ScreenDC, 0, 0, srcCopy );
  finally
    ReleaseDC ( 0, ScreenDC );
    SetBounds ( 0, 0, Screen.Width, Screen.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;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.FormMouseDown ( Sender: TObject;Button: TMouseButton;
  Shift: TShiftState;X, Y: Integer );
begin
  RemoveTheRect; // Erase any existing rectangle
  X1 := X;Y1 := Y;X2 := X;Y2 := Y;
  SetRect ( fRect, X, Y, X, Y ); // Set initial rectangle position
end;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.FormMouseMove ( Sender: TObject;Shift: TShiftState;X,
  Y: 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; // Draw the Rect now... don't wait for the timer!
    fRect.Right := X; // Set the position of the rectangle to capture
    fRect.Bottom := Y;
  end;
end;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.FormMouseUp ( Sender: TObject;Button: TMouseButton;
  Shift: TShiftState;X, Y: Integer );
var
  ScreenDC: HDC;
  Bitmap: TBitmap;
begin
  if Button = mbLeft then begin
    Bitmap := TBitmap.Create;
   // Set fRect
    fRect.Left := X1;
    fRect.Top := Y1;
    fRect.Right := X2;
    fRect.Bottom := 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
        BitBlt ( Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, ScreenDC, fRect.Left, fRect.Top,
          SRCCOPY );
        RectBitmap.Assign ( Bitmap );
        fBmp.Assign ( Bitmap );
      finally
        ReleaseDC ( 0, ScreenDC );
        Bitmap.Free;
      end;
    end; // if
    ModalResult := mrOK;
  end;
end;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.FormPaint ( Sender: TObject );
begin
  Canvas.Draw ( 0, 0, fBMP );
end;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.FormDestroy ( Sender: TObject );
begin
  fBMP.Free;
  RectBitmap.Free;
end;

{--------------------------------------------------------------------------}
procedure TCaptureRectForm.WMEraseBkGnd ( var Msg: TWMEraseBkGnd );
begin
  Msg.Result := 1;
end;

{ Animated Rubbanding }
{--------------------------------------------------------------------------}
procedure TCaptureRectForm.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; // Draw the rectangle
end;

end.