scapture.pas

This archive includes the Delphi component TScreenCapture (D3,D4,D5) that implements an interface t

{*******************************************************}
{                                                       }
{       TScreenCapture for Delphi 3, 4, 5               }
{       Copyright (c) 1997 - 2001 EC Software           }
{                                                       }
{       Delphi Implementation of the T.N.T              }
{       screen capture function.                        }
{                                                       }
{       In order to use this component, you must        }
{       install the T.N.T screen capture utility.       }
{       Download:                                       }
{       http://www.ec-software.com                      }
{                                                       }
{*******************************************************}

unit SCapture;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, ComCtrls, Menus, Clipbrd;

const
  TNT_ALL = 0;
  TNT_CAPTUREWIDTH = 1;
  TNT_CAPTUREHEIGHT = 2;
  TNT_BACKGROUND = 3;
  TNT_ZOOM = 4;
  TNT_ZOOMFILTER = 5;
  TNT_INCLUDECURSOR = 6;
  TNT_ADDSPARKLE = 7;

  TNT_DRAWSHADOW = 8;
  TNT_DRAWCURSORSHADOW = 9;
  TNT_SHADOWCOLOR = 10;
  TNT_SHADOWDIRECTION = 11;
  TNT_SHADOWOFFSET = 12;
  TNT_SHADOWINTENSITY = 13;
  TNT_SHADOWDITHER = 14;

  TNT_SHAPE = 15;
  TNT_FADEOUT = 16;
  TNT_ENABLESOUND = 17;

  TNT_DEFAULT = 0;

  TNT_RECTANGLE = 0;
  TNT_ROUNDRECT = 1;
  TNT_ELLIPSE = 2;
  TNT_RIGHTPAPEREDGE = 3;
  TNT_LEFTPAPEREDGE = 4;
  TNT_AUTOSHAPE = 99;

  TNT_FADENONE = 1;
  TNT_FADESOFT = 2;
  TNT_FADELEFT = 180;
  TNT_FADETOPLEFT = 135;
  TNT_FADETOP = 90;
  TNT_FADETOPRIGHT = 45;
  TNT_FADERIGHT = 0;
  TNT_FADEBOTTOMRIGHT = 315;
  TNT_FADEBOTTOM = 270;
  TNT_FADEBOTTOMLEFT = 225;


type
  TTNTZoomFilter = (tzfNone, tzfTriangle, tzfHermite, tzfBell, tzfBSpline, tzfLanczos3, tzfMitchell);
  TTNTImageShape = (tisRectangle, tisRoundRect, tisEllipse, tisRightPaperEgde,
                    tisLeftPaperEgde, tisAutoShape);
  TTNTImageFader = (tifNone, tifSoftBorder, tifLeft, tifTopLeft, tifTop,
                    tifTopRight, tifRight, tifBottomRight, tifBottom, tifBottomLeft);
  TTNTSparkle = (tsNone, tsTwinkle, tsHotMouseAction, tsSoftClick, tsDoubleClick);
  TTNTCaptureMode = (tcmWindow, tcmFreeRegion, tcmFixedRegion);

  TCaptureEvent = procedure(Sender: TObject; Bitmap: TBitmap) of object;

  TScreenCapture = class(TComponent)
  private
    fCaptureMode: TTNTCaptureMode;

    fBackgroundColor: TColor;
    fCaptureWidth: integer;
    fCaptureHeight: integer;
    fZoom: word;
    fZoomFilter: TTNTZoomFilter;

    fShape: TTNTImageShape;
    fFader: TTNTImageFader;
    fSparkle: TTNTSparkle;

    fIncludeCursor: boolean;
    fCursorShadow: boolean;
    fImageShadow: boolean;

    fShadowColor: TColor;
    fShadowIntensity: word;
    fShadowOffset: word;
    fShadowDirection: word;
    fShadowDither: word;

    fApplicationMinimize: boolean;
    fSoundsEnabled: boolean;

    fOldAppRestore: TNotifyEvent;
    fCopyClipboard: boolean;
    fSaveToFile: boolean;
    fFilename: string;
    fImage: TImage;
    fOnCaptureStart: TNotifyEvent;
    fOnCaptureSuccess: TCaptureEvent;
    fOnCaptureError: TNotifyEvent;
    fOnUserCancelled: TNotifyEvent;

    function  GetVersion: string;
    procedure SetVersion(value: string);
    procedure SetCaptureWidth(value: integer);
    procedure SetCaptureHeight(value: integer);
    procedure SetZoom(value: word);
    procedure SetShadowIntensity(value: word);
    procedure SetShadowOffset(value: word);
    procedure SetShadowDirection(value: word);
    procedure SetShadowDither(value: word);
    procedure SetSaveToFile(value: boolean);
    procedure SetImage(aImage: TImage);
    procedure CaptureCallBack(result: word; BitmapHandle: hBitmap);
    procedure AppOnRestore(Sender: TObject);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function  Start: boolean;
    procedure Stop;
    function  DLLAvailable: boolean;
  published
    property ApplicationMinimize: boolean read fApplicationMinimize write fApplicationMinimize;
    property CaptureMode: TTNTCaptureMode read fCaptureMode write fCaptureMode;
    property BackgroundColor: TColor read fBackgroundColor write fBackgroundColor;
    property CaptureWidth: integer read fCaptureWidth write SetCaptureWidth;
    property CaptureHeight: integer read fCaptureHeight write SetCaptureHeight;
    property Zoom: word read fZoom write SetZoom;
    property ZoomFilter: TTNTZoomFilter read fZoomFilter write fZoomFilter;
    property Shape: TTNTImageShape read fShape write fShape;
    property Fader: TTNTImageFader read fFader write fFader;
    property Sparkle: TTNTSparkle read fSparkle write fSparkle;
    property IncludeCursor: boolean read fIncludeCursor write fIncludeCursor;
    property CursorShadow: boolean read fCursorShadow write fCursorShadow;
    property ImageShadow: boolean read fImageShadow write fImageShadow;
    property ShadowColor: TColor read fShadowColor write fShadowColor;
    property ShadowIntensity: word read fShadowIntensity write SetShadowIntensity;
    property ShadowOffset: word read fShadowOffset write SetShadowOffset;
    property ShadowDirection: word read fShadowDirection write SetShadowDirection;
    property ShadowDither: word read fShadowDither write SetShadowDither;
    property CopyClipboard: boolean read fCopyClipboard write fCopyClipboard;
    property SoundsEnabled: boolean read fSoundsEnabled write fSoundsEnabled;
    property SaveToFile: boolean read fSaveToFile write SetSaveToFile;
    property Filename: string read fFilename write fFilename;
    property Image: TImage read fImage write SetImage;
    property OnCaptureStart: TNotifyEvent read fOnCaptureStart write fOnCaptureStart;
    property OnCaptureSuccess: TCaptureEvent read fOnCaptureSuccess write fOnCaptureSuccess;
    property OnCaptureError: TNotifyEvent read fOnCaptureError write fOnCaptureError;
    property OnUserCancelled: TNotifyEvent read fOnUserCancelled write fOnUserCancelled;
    property Version: string read GetVersion write SetVersion;
  end;

const
  CAPTUREDLL = 'ECTNTCAP.DLL';

type
   TCaptureCallbackProc = procedure(result: word; BitmapHandle: hBitmap; AppData: longint); stdcall;

   TGetCaptureVersion = function: integer; stdcall;
   TStartCapture = function(CaptureMode: word; HotkeyModifier, Hotkey: integer; ParentHandle: integer; callbackfunc: TCaptureCallbackProc; AppData: longint): Bool; stdcall;
   TStopCapture = function: boolean; stdcall;
   TGetCaptureProperty = function(AProperty: integer): integer; stdcall;
   TSetCaptureProperty = procedure(AProperty, AValue: integer); stdcall;

var
   GetCaptureVersion: TGetCaptureVersion;
   StartCapture: TStartCapture;
   StopCapture: TStopCapture;
   GetCaptureProperty: TGetCaptureProperty;
   SetCaptureProperty: TSetCaptureProperty;
   CaptureDLLHandle: THandle;

function  LoadCaptureDLL: boolean;
procedure UnloadCaptureDLL;
procedure Register;

implementation

procedure ScreenCaptureCallback(result: word; BitmapHandle: hBitmap; AppData: longint); export; stdcall;
begin
     TScreenCapture(AppData).CaptureCallBack(result, BitmapHandle);
end;

constructor TScreenCapture.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  fApplicationMinimize := true;
  fCaptureMode := tcmWindow;
  fBackgroundColor := clWhite;
  fCaptureWidth := 100;
  fCaptureHeight := 100;
  fZoom := 100;
  fZoomFilter := tzfNone;

  fShape := tisRectangle;
  fFader := tifNone;
  fSparkle := tsNone;

  fIncludeCursor := false;
  fCursorShadow := false;
  fImageShadow := false;

  fShadowColor := clBlack;
  fShadowIntensity := 50;
  fShadowOffset := 4;
  fShadowDirection := 315; //bottom-right
  fShadowDither := 5;

  fCopyClipboard := false;
  fSaveToFile := false;
  fSoundsEnabled := true;

  if not (csDesigning in ComponentState) then LoadCaptureDLL;
end;

destructor TScreenCapture.Destroy;
begin
  Stop;
  inherited Destroy;
end;

function TScreenCapture.DLLAvailable: boolean;
begin
     result := CaptureDLLHandle <> 0;
end;

function TScreenCapture.GetVersion: string;
var
   i: integer;
begin
     if (csDesigning in ComponentState) then result := '(DLL not loaded)'
     else begin
       result := '(DLL not found!)';
       if CaptureDLLHandle <> 0 then
       begin
          i := GetCaptureVersion;
          result := format('%2.2f', [i/100]);
       end;
     end;
end;

procedure TScreenCapture.SetVersion(value: string);
begin
     //dummy
end;

procedure TScreenCapture.SetCaptureWidth(value: integer);
begin
     if (value > 0) and (value <= screen.width) then fCaptureWidth := value;
end;

procedure TScreenCapture.SetCaptureHeight(value: integer);
begin
     if (value > 0) and (value <= screen.height) then fCaptureHeight := value;
end;

procedure TScreenCapture.SetZoom(value: word);
begin
     fZoom := value;
     if fZoom = 100 then fZoomFilter := tzfNone
     else if fZoom < 100 then fZoomFilter := tzfLanczos3
     else if fZoom > 100 then fZoomFilter := tzfBSpline;
end;

procedure TScreenCapture.SetShadowIntensity(value: word);
begin
     if (value <= 100) then fShadowIntensity := value;
end;

procedure TScreenCapture.SetShadowOffset(value: word);
begin
     if (value <= 100) then fShadowOffset := value;
end;

procedure TScreenCapture.SetShadowDirection(value: word);
begin
     if (value <= 359) then fShadowDirection := value;
end;

procedure TScreenCapture.SetShadowDither(value: word);
begin
     if (value <= 20) then fShadowDither := value;
end;

procedure TScreenCapture.SetSaveToFile(value: boolean);
begin
     fSaveToFile := value;
end;

procedure TScreenCapture.SetImage(aImage: TImage);
begin
     fImage := aImage;
end;

procedure TScreenCapture.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = fImage) then fImage := nil;
end;

function TScreenCapture.Start: boolean;
begin
     result := false;
     if CaptureDLLHandle = 0 then exit;

     StopCapture;
     SetCaptureProperty(TNT_ALL, 0);  //reset defaults

     SetCaptureProperty(TNT_BACKGROUND, fBackgroundColor);
     SetCaptureProperty(TNT_ZOOM, fZoom);
     SetCaptureProperty(TNT_ZOOMFILTER, integer(fZoomFilter));
     SetCaptureProperty(TNT_CAPTUREWIDTH, fCaptureWidth);
     SetCaptureProperty(TNT_CAPTUREHEIGHT, fCaptureHeight);
     SetCaptureProperty(TNT_INCLUDECURSOR, integer(fIncludeCursor));
     SetCaptureProperty(TNT_ADDSPARKLE, integer(fSparkle));

     case fShape of
     tisAutoShape: SetCaptureProperty(TNT_SHAPE, 99);
     else          SetCaptureProperty(TNT_SHAPE, integer(fShape));
     end;

     case fFader of
     tifNone:        SetCaptureProperty(TNT_FADEOUT, TNT_FADENONE);
     tifSoftBorder:  SetCaptureProperty(TNT_FADEOUT, TNT_FADESOFT);
     tifRight:       SetCaptureProperty(TNT_FADEOUT, TNT_FADERIGHT);
     tifTopRight:    SetCaptureProperty(TNT_FADEOUT, TNT_FADETOPRIGHT);
     tifTop:         SetCaptureProperty(TNT_FADEOUT, TNT_FADETOP);
     tifTopLeft:     SetCaptureProperty(TNT_FADEOUT, TNT_FADETOPLEFT);
     tifLeft:        SetCaptureProperty(TNT_FADEOUT, TNT_FADELEFT);
     tifBottomLeft:  SetCaptureProperty(TNT_FADEOUT, TNT_FADEBOTTOMLEFT);
     tifBottom:      SetCaptureProperty(TNT_FADEOUT, TNT_FADEBOTTOM);
     tifBottomRight: SetCaptureProperty(TNT_FADEOUT, TNT_FADEBOTTOMRIGHT);
     end;

     SetCaptureProperty(TNT_DRAWSHADOW, integer(fImageShadow));
     SetCaptureProperty(TNT_DRAWCURSORSHADOW, integer(fCursorShadow));
     SetCaptureProperty(TNT_SHADOWCOLOR, fShadowColor);
     SetCaptureProperty(TNT_SHADOWDIRECTION, fShadowDirection);
     SetCaptureProperty(TNT_SHADOWOFFSET, fShadowOffset);
     SetCaptureProperty(TNT_SHADOWINTENSITY, fShadowIntensity);
     SetCaptureProperty(TNT_SHADOWDITHER, fShadowDither);

     SetCaptureProperty(TNT_ENABLESOUND, integer(fSoundsEnabled));

     if fApplicationMinimize then
     begin
          Application.Minimize;
          fOldAppRestore := Application.onrestore;
          Application.onrestore := AppOnRestore;
     end;

     if assigned(fOnCaptureStart) then fOnCaptureStart(self);

     if StartCapture(integer(fCaptureMode), 0, 0, TForm(owner).handle, @ScreenCaptureCallback, integer(self)) then result := true
     else if fApplicationMinimize then Application.restore;
end;

procedure TScreenCapture.Stop;
begin
     if CaptureDLLHandle <> 0 then StopCapture;
end;

procedure TScreenCapture.CaptureCallBack(result: word; BitmapHandle: hBitmap);
var
   bmp: TBitmap;
begin
     if fApplicationMinimize then Application.restore;

     case result of
     0: if assigned(fOnUserCancelled) then fOnUserCancelled(self);
     1: if (BitmapHandle <> 0) then
        begin
          bmp := TBitmap.create;
          bmp.releaseHandle;
          bmp.handle := CopyImage(BitmapHandle, IMAGE_BITMAP, 0,0, LR_COPYDELETEORG);

          if assigned(fImage) then fImage.picture.bitmap.assign(bmp);
          if fCopyClipboard then Clipboard.assign(bmp);
          if fSaveToFile and (fFilename <> '') then
          try
            bmp.savetofile(fFilename);
          except
            MessageDlg('Cannot save file '+fFilename, mtError, [mbOK], 0);
          end;
          if assigned(fOnCaptureSuccess) then fOnCaptureSuccess(self, bmp);
          bmp.free;
        end;
     else
        if assigned(fOnCaptureError) then fOnCaptureError(self);
     end;
end;

procedure TScreenCapture.AppOnRestore(Sender: TObject);
begin
     Stop;
     Application.OnRestore := fOldAppRestore;
     fOldAppRestore := nil;
end;

procedure Register;
begin
  RegisterComponents('EC', [TScreenCapture]);
end;

function LoadCaptureDLL: boolean;
begin
  result := CaptureDLLHandle <> 0;
  if not result then
  begin
    CaptureDLLHandle := LoadLibrary(CAPTUREDLL);
    if (CaptureDLLHandle <> 0) then
    try
       GetCaptureVersion  := GetProcAddress(CaptureDLLHandle, 'GetDLLVersion');
       StartCapture       := GetProcAddress(CaptureDLLHandle, 'StartCapture');
       StopCapture        := GetProcAddress(CaptureDLLHandle, 'StopCapture');
       GetCaptureProperty := GetProcAddress(CaptureDLLHandle, 'GetCaptureProperty');
       SetCaptureProperty := GetProcAddress(CaptureDLLHandle, 'SetCaptureProperty');
       result := true;
    except
      {no error here}
    end;
  end;
end;

procedure UnloadCaptureDLL;
begin
  if (CaptureDLLHandle <> 0) then FreeLibrary(CaptureDLLHandle);
  CaptureDLLHandle := 0;
end;

initialization
  CaptureDLLHandle := 0;
  //LoadCaptureDLL;

finalization
  UnloadCaptureDLL;

end.