{*******************************************************}
{                                                       }
{       TScreenCapture                                  }
{                                                       }
{*******************************************************}

unit SCapture;

interface

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

type
  TScreenCapture = class(TCustomControl)
  private
    fKeyRegistered: Boolean;
    fBitmap: TBitmap;
    fActive: Boolean;
    fTimerActivated: Boolean;
    fAutocopy: Boolean;
    fDesktop: Boolean;
    fHotKey: TShortCut;
    fOnBeforeCapture: TNotifyEvent;
    fOnCapture: TNotifyEvent;
    procedure SetActive(Value: Boolean);
    procedure UpdatefHotKey(Value: TShortCut);
  protected
    procedure loaded; override;
    procedure WndProc(var Message: TMessage); override;
    procedure Paint; override;
  public
    CanCapture: Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function    Bitmap: TBitmap;
    procedure   Capture;
    procedure   Copytoclipboard;
  published
    property TimerActivated: Boolean read fTimerActivated write fTimerActivated;
    property KeyRegistered: Boolean read fKeyRegistered;
    property Autocopy: Boolean read fAutocopy write fAutocopy;
    property Active: Boolean read fActive write SetActive;
    property Desktop: Boolean read fDesktop write fDesktop;
    property HotKey: TShortCut read fHotKey write UpdatefHotKey;
    property OnBeforeCapture: TNotifyEvent read fOnBeforeCapture write fOnBeforeCapture;
    property OnCapture: TNotifyEvent read fOnCapture write fOnCapture;
  end;

procedure Register;

implementation

var Old: TShortCut;

constructor TScreenCapture.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fBitmap := TBitmap.create;
  fActive := false;
  fHotKey := TextToShortCut('');
  Visible := false;
  height := 28;
  width := 28;
end;

destructor TScreenCapture.Destroy;
begin
  fBitmap.free;
  inherited Destroy;
end;

procedure TScreenCapture.Paint;
var
   PaintRect: TRect;
   Bmp: TBitmap;
   ResName : array[0..15] of char;
begin
   if (csDesigning in ComponentState) then
   begin
        PaintRect := Rect(0, 0, Width, Height);
        Frame3D(Canvas, PaintRect, clBtnHighlight, clBtnShadow, 1);
        Bmp := TBitmap.create;
        StrPCopy(ResName,classname);
        Bmp.handle := LoadBitmap(hinstance,ResName);
        BitBlt(canvas.handle, 2, 2, ClientRect.Right-4, ClientRect.Bottom-4, Bmp.canvas.handle, 0, 0, SRCCOPY);
        Bmp.free;
   end;
end;

function TScreenCapture.Bitmap: TBitmap;
begin
     result := fBitmap;
end;

procedure TScreenCapture.SetActive(Value: Boolean);
begin
     fActive := Value;
end;

procedure TScreenCapture.UpdatefHotKey(Value: TShortCut);
begin
  if not (csDesigning in ComponentState) then
   begin
    if fKeyRegistered then
     if not UnregisterHotKey(handle,IDHOT_SNAPWINDOW) then
      begin
       fKeyRegistered := False;
       Application.MessageBox(PChar('Unable to unregister capture hotkey "'+ShortCutToText(fHotKey)+'".'+#13#13+
       'Another application may have locked it.  Try closing all other applications.'),'Hotkey Error',MB_OK+MB_ICONERROR);
      end
     else
      begin
       Old := fHotKey;
       fHotKey := Value;
       Loaded;
       { Key was not registered }
       if not fKeyRegistered then
        Loaded;
      end
    else
     if ShortCutToText(Value)<>'' then
      begin
       fHotKey := Value;
       Loaded;
      end
   end;
end;

procedure TScreenCapture.loaded;
var Shift: TShiftState;
    Key: Word;
    fsModifiers: Cardinal;
begin
  if not (csDesigning in ComponentState) then
  begin
   ShortCutToKey(fHotKey,Key,Shift);
   fsModifiers := Cardinal(nil);
   if ssCtrl in Shift then
    fsModifiers := fsModifiers + MOD_CONTROL;
   if ssAlt in Shift then
    fsModifiers := fsModifiers + MOD_ALT;
   if ssShift in Shift then
    fsModifiers := fsModifiers + MOD_SHIFT;
   fKeyRegistered := True;
   if (not RegisterHotkey(handle, IDHOT_SNAPWINDOW, fsModifiers{MOD_ALT}, Key{VK_F12})) then
    begin
      fKeyRegistered := False;
      Application.MessageBox(PChar('Unable to register capture hotkey "'+ShortCutToText(fHotKey)+'".  It may be locked '+
      'by another application.'+#13#13+
      'Try changing the hotkey or closing all other applications.'),'Hotkey Error',MB_OK+MB_ICONERROR);
      fHotKey := Old;
    end;
  end;
end;

procedure TScreenCapture.WndProc(var Message: TMessage);
begin
    if (Message.Msg = WM_HOTKEY) and (Message.wParam = IDHOT_SNAPWINDOW) and fActive then
     if fTimerActivated then
      fTimerActivated := False
     else
      Capture;
    inherited WndProc(Message);
end;

procedure TScreenCapture.Capture;
var
   winHWND: HWND;
   winDC: HDC;
   Rect: TRect;
begin
     if (assigned(fOnBeforeCapture)) then fOnBeforeCapture(self);
     if fDesktop then
     begin
          winHWND := GetDesktopWindow();
          winDC := GetDC(winHWND);
     end else
     begin
          winHWND := Getforegroundwindow();
          winDC := GetwindowDC(winHWND);
     end;
     GetWindowRect(winHWND, rect);
     fBitmap.width := rect.right-rect.left;
     fBitmap.height := rect.bottom-rect.top;
     BitBlt(fBitmap.canvas.handle, 0, 0, fBitmap.width, fBitmap.height, winDC, 0, 0, SRCCOPY);
     ReleaseDC(winHWND, winDC);

     if fAutocopy then Copytoclipboard;
     if assigned(fOnCapture) then fOnCapture(self);
end;

procedure TScreenCapture.Copytoclipboard;
var
   AFormat : Word;
   AData{, APalette }: THandle;
   APalette: HPALETTE;
begin
     fBitmap.SaveToClipBoardFormat(AFormat,AData,APalette);
     Clipboard.SetAsHandle(AFormat,AData);
end;

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

end.
