capturetheobject.pas

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

{----------------------------------------------------------------------------
| Library: ASG CaptureObject
| (C) Copyright Adirondack Software & Graphics 1996-2000
|
| Module: CaptureObject Form for ASGScreenCapture.CaptureTheObject Form
|
| Description: A form for displaying the Screen to select an object.
|
| This form copys an image of the screen into the form, then displays a "finger cursor" to allow the
| user to select an object.
|
| Known Problems: None
|
| History: Previously developed as an application in the 1990's.
|          July 4 2000. William Miller, first BETA version
|          September 21, 2000. William Miller, Version 1.0
|---------------------------------------------------------------------------}

unit CaptureTheObject;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
   TCaptureObjectForm = class ( TForm )
      procedure FormCreate ( Sender: TObject );
      procedure FormMouseUp ( Sender: TObject;Button: TMouseButton;
         Shift: TShiftState;X, Y: Integer );
      procedure FormDestroy ( Sender: TObject );
      procedure FormActivate ( Sender: TObject );
   private
    { Private declarations }
    procedure WMEraseBkGnd ( var Msg: TWMEraseBkGnd );message WM_ERASEBKGND;
   public
    { Public declarations }
      fBmp: TBitmap;
   end;

var
   CaptureObjectForm: TCaptureObjectForm;

implementation

{$R *.DFM}
{$R CaptureObject.Res}

{--------------------------------------------------------------------------}
// Create the form
procedure TCaptureObjectForm.FormCreate ( Sender: TObject );
var
   ScreenDC: HDC;
   lpPal: PLogPalette;
const
   crHand = -18;
begin
   Screen.Cursors[ crHand ] := LoadCursor ( hInstance, pChar ( 'CURSOR_1' ) );
   Cursor := crHand;
   fBMP := 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;
   BitBlt ( fBMP.Canvas.handle, 0, 0, Screen.Width, Screen.Height,
      ScreenDC, 0, 0, srcCopy );
   ReleaseDC ( 0, ScreenDC );
   SetBounds ( 0, 0, Screen.Width, Screen.Height );
end;

{--------------------------------------------------------------------------}
// Process FormMouseUp event
procedure TCaptureObjectForm.FormMouseUp ( Sender: TObject;Button: TMouseButton;
   Shift: TShiftState;X, Y: Integer );
begin
   ModalResult := mrOK;
   CaptureObjectForm := nil;
end;

{--------------------------------------------------------------------------}
// Form Destroy
procedure TCaptureObjectForm.FormDestroy ( Sender: TObject );
begin
   fBMP.Free;
   Screen.Cursor := crDefault;
end;

{--------------------------------------------------------------------------}
// Activate the Form
procedure TCaptureObjectForm.FormActivate ( Sender: TObject );
const
   crHand = -18;
begin
   Screen.Cursors[ crHand ] := LoadCursor ( hInstance, pChar ( 'CURSOR_1' ) );
   Cursor := crHand;
end;

{--------------------------------------------------------------------------}

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

end.