API - capturar a tela inclusive o cursor do mouse

unit FTScreenshot;

(******************************************************************************

Unit to make a screenshot with or without the mouse cursor.

Author: Finn Tolderlund

        Denmark

Date: 01.07.2003

homepage:

http://home20.inet.tele.dk/tolderlund/

http://finn.mobilixnet.dk/

e-mail:

finn@mail.tdcadsl.dk

finn.tolderlund@mobilixnet.dk

Tested with Delphi 5, 6 and 7.

This unit can freely be used and distributed.

Disclaimer:

Use of this unit is on your own responsibility.

I will not under any circumstance be hold responsible for anything

which may or may not happen as a result of using this unit.

*******************************************************************************

First version 01.07.2003

Changed 02.07.2003

Added a new overloaded Screenshot function to make screenshot

of only an area of the screen including the cursor.

******************************************************************************)

interface

uses

  Windows, SysUtils, Classes, Graphics;

function Screenshot(IncludeCursor: Boolean): TBitmap; overload;

{ Take a screenshot of whole screen, including the cursor.

  The cursour will not be included on Windows 95 which lacks the GetCursorInfo API.

  Example:

var

  bm: TBitmap;

begin

  bm := Screenshot(True);

  try

    bm.SaveToFile('c:\test.bmp');

  finally

    bm.Free;

  end;

end;

}

function Screenshot(IncludeCursor: Boolean; const ScreenArea: TRect): TBitmap; overload;

{ Take a screenshot of an area of the screen, including the cursor.

  The cursour will not be included on Windows 95 which lacks the GetCursorInfo API.

  Example:

var

  bm: TBitmap;

begin

  bm := Screenshot(True, Form1.BoundsRect);  // whole form (visible part)

  try

    bm.SaveToFile('c:\test.bmp');

  finally

    bm.Free;

  end;

end;

}

procedure Screenshot(const Bitmap: TBitmap; const ScreenArea: TRect); overload;

{ take a screenshot of the ScreeanArea Rect, excluding the bottom and right edges.

  Example:

var

  bm: TBitmap;

begin

  bm := TBitmap.Create;

  try

    Screenshot(bm, Rect(0, 0, Screen.Width, Screen.Height));  // whole screen

or

    Screenshot(bm, Form1.BoundsRect);  // whole form (visible part)

    bm.SaveToFile('c:\test.bmp');

  finally

    bm.Free;

  end;

end;

}

implementation

procedure Screenshot(const Bitmap: TBitmap; const ScreenArea: TRect);

var

  BitmapRect, ScreenRect: TRect;

  DesktopDC: HDC;

  DesktopCanvas: TCanvas;

begin

  BitmapRect := Rect(0, 0, ScreenArea.Right - ScreenArea.Left, ScreenArea.Bottom - ScreenArea.Top);

  ScreenRect := Rect(ScreenArea.Left, ScreenArea.Top, ScreenArea.Right, ScreenArea.Bottom);

  Bitmap.PixelFormat := pf24bit;  // optional

  Bitmap.Width  := ScreenArea.Right  - ScreenArea.Left;

  Bitmap.Height := ScreenArea.Bottom - ScreenArea.Top;

  DesktopDC := GetWindowDC(GetDeskTopWindow);

  try

    DesktopCanvas := TCanvas.Create;

    try

      DesktopCanvas.Handle := DesktopDC;

      Bitmap.Canvas.CopyMode := cmSrcCopy;

      Bitmap.Canvas.CopyRect(BitmapRect, DesktopCanvas, ScreenRect);

    finally

      DesktopCanvas.Free;

    end;

  finally

    ReleaseDC(GetDeskTopWindow, DesktopDC);

  end;

end;

function GetCursorInfo(var pci: TCursorInfo): Boolean;

// GetCursorInfo is in Windows.pas, but I implement the GetCursorInfo API here

// so it doesn't crash on Windows 95 which lacks this API.

// GetCursorInfo, Minimum operating systems: Windows 98, Windows NT 4.0 SP6

// Windows NT/2000: Requires Windows NT 4.0 SP6 or later.

// Windows 95/98: Requires Windows 98 or later.

type

  TGetCursorInfo = function(var pci: TCursorInfo): BOOL; stdcall;

const

  cUser32 = 'User32.dll';

var

  hMod: HMODULE;

  _GetCursorInfo: TGetCursorInfo;

begin

  Result := False;

  hMod := GetModuleHandle(cUser32);

  if hMod <> 0 then

  begin

    @_GetCursorInfo := GetProcAddress(hMod, 'GetCursorInfo');

    if Assigned(_GetCursorInfo) then

      Result := _GetCursorInfo(pci);

  end;

end;

function Screenshot(IncludeCursor: Boolean): TBitmap;

var

  r: TRect;

  CI: TCursorInfo;

  Icon: TIcon;

  II: TIconInfo;

begin

  Result := TBitmap.Create;

  r := Rect(0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN));

  Screenshot(Result, r);

  if IncludeCursor then

  begin

    Icon := TIcon.Create;

    try

      CI.cbSize := SizeOf(CI);

      if GetCursorInfo(CI) then

        if CI.flags = CURSOR_SHOWING then

        begin

          Icon.Handle := CopyIcon(CI.hCursor);

          if GetIconInfo(Icon.Handle, II) then

          begin

            Result.Canvas.Draw(ci.ptScreenPos.x - Integer(II.xHotspot), ci.ptScreenPos.y - Integer(II.yHotspot), Icon);

          end;

        end;

    finally

      Icon.Free;

    end;

  end;

end;

function Screenshot(IncludeCursor: Boolean; const ScreenArea: TRect): TBitmap;

var

  r: TRect;

  CI: TCursorInfo;

  Icon: TIcon;

  II: TIconInfo;

begin

  Result := TBitmap.Create;

  r := ScreenArea;

  Screenshot(Result, r);

  if IncludeCursor then

  begin

    Icon := TIcon.Create;

    try

      CI.cbSize := SizeOf(CI);

      if GetCursorInfo(CI) then

        if CI.flags = CURSOR_SHOWING then

        begin

          Icon.Handle := CopyIcon(CI.hCursor);

          if GetIconInfo(Icon.Handle, II) then

          begin

            Result.Canvas.Draw(ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left, ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top, Icon);

          end;

        end;

    finally

      Icon.Free;

    end;

  end;

end;

end.