Code:

// В качестве параметров передаются:

// AHandle - хэндл окна, скриншот которого мы хочем получить

// CompressPercent - процент сжатия картинки

// AImage - картинка, в которую будет помещено изображение

// в случае успешного скриншота функция вернет True

{©Drkb v.3(2007): www.drkb.ru}

function GetScreenShot(const AHandle: THandle; const CompressPercent: Byte;

var AImage: TJPEGImage): Boolean;

var

fBitmap: TBitmap;

DC: HDC;

Rect: TRect;

begin

Result := False;

if AImage = nil then Exit;

DC := GetDC(AHandle);

if DC <> 0 then

try

   fBitmap := TBitmap.Create;

   try

     if not GetClientRect(AHandle, Rect) then Exit;

     fBitmap.Width := Rect.Right - Rect.Left;

     fBitmap.Height := Rect.Bottom - Rect.Top;

     fBitmap.PixelFormat := pf32bit;

     Result := BitBlt(fBitmap.Canvas.Handle, 0, 0, fBitmap.Width,

       fBitmap.Height, DC, 0, 0, SRCCOPY);

     if not Result then Exit;

     AImage.Assign(fBitmap);

     AImage.CompressionQuality := CompressPercent;

   finally

     fBitmap.Free;

   end;

finally

   ReleaseDC(AHandle, DC);

end;

end;

// Пример использования...

procedure TForm1.Button1Click(Sender: TObject);

var

Image: TJPEGImage;

begin

// Скриншот рабочего стола

Image := TJPEGImage.Create;

try

   if GetScreenShot(GetDesktopWindow, 150, Image) then

     Image1.Picture.Assign(Image);

finally

   Image.Free;

end;

// Скриншот нашей формы

Image := TJPEGImage.Create;

try

   if GetScreenShot(Handle, 150, Image) then

     Image2.Picture.Assign(Image);

finally

   Image.Free;

end;

end;

Code:

keybd_event(VK_SNAPSHOT,1,KEYEVENTF_KEYUP,0);

OpenClipBoard(Form1.handle);

try

SetClipBoardData(CF_DIB,Form1.handle);

vv:=GetClipBoardData(CF_BITMAP);

Image1.Picture.LoadFromClipboardFormat(CF_BITMAP,vv,0);

finally

CloseClipBoard;

EmptyClipBoard;

end;

Code:

function CreateWindwowBitmap(Wnd: HWND): HBITMAP;

{©Drkb v.3(2007): www.drkb.ru}

var

R: TRect;

W, H: Integer;

DC, memDC: HDC;

bm, oldBM: HBITMAP;

begin

GetWindowRect(Wnd, R);

W := R.Right - R.Left;

H := R.Bottom - R.Top;

DC := GetWindowDC(Wnd);

memDC := CreateCompatibleDC(DC);

bm := CreateCompatibleBitmap(DC, W, H);

oldBM := SelectObject(memDC, bm);

BitBlt(memDC, 0,0, w, h, DC, 0,0, SRCCOPY);

SelectObject(memDC, oldBM);

DeleteDC(memDC);

DeleteObject(oldBM);

ReleaseDC(Wnd, DC);

Result := bm;

end;

Code:

procedure CaptureScreen(AFileName: string);

const

CAPTUREBLT = $40000000;

var

hdcScreen: HDC;

hdcCompatible: HDC;

bmp: TBitmap;

hbmScreen: HBITMAP;

begin

// Create a normal DC and a memory DC for the entire screen. The

// normal DC provides a "snapshot" of the screen contents. The

// memory DC keeps a copy of this "snapshot" in the associated

// bitmap.

hdcScreen := CreateDC('DISPLAY', nil, nil, nil);

hdcCompatible := CreateCompatibleDC(hdcScreen);

// Create a compatible bitmap for hdcScreen.

hbmScreen := CreateCompatibleBitmap(hdcScreen,

   GetDeviceCaps(hdcScreen, HORZRES),

   GetDeviceCaps(hdcScreen, VERTRES));

// Select the bitmaps into the compatible DC.

SelectObject(hdcCompatible, hbmScreen);

bmp := TBitmap.Create;

bmp.Handle := hbmScreen;

BitBlt(hdcCompatible,

   0, 0,

   bmp.Width, bmp.Height,

   hdcScreen,

   0, 0,

   SRCCOPY or CAPTUREBLT);

bmp.SaveToFile(AFileName);

bmp.Free;

DeleteDC(hdcScreen);

DeleteDC(hdcCompatible);

end;

// from http://www.swissdelphicenter.ch

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

DeskTop: TCanvas;

begin

DeskTop := TCanvas.Create;

try

   with DeskTop do

     Handle := GetWindowDC(GetDesktopWindow);

   with PaintBox1.Canvas do

     CopyRect(Rect(0, 0, 200, 200),

       DeskTop,

       Rect(0, 0, 200, 200))

finally

   DeskTop.Free;

end

end;

Code:

var

bmp: TBitmap;

DC: HDC;

begin

bmp:=TBitmap.Create;

bmp.Height:=Screen.Height;

bmp.Width:=Screen.Width;

DC:=GetDC(0);  //Дескpиптоp экpана

bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,

   DC, 0, 0, SRCCOPY);

bmp.SaveToFile('Screen.bmp');

ReleaseDC(0, DC);

end;

Code:

Var

Desktop: TCanvas ;

BitMap: TBitMap;

begin

DesktopCanvas:=TCanvas.Create;

DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);

BitMap := TBitMap.Create;

BitMap.Width := Screen.Width;

BitMap.Height:=Screen.Height;

Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,

DesktopCanvas, DesktopCanvas.ClipRect);

........

end;

Code:

unit ScrnCap;

interface

uses

WinTypes, WinProcs, Forms, Classes, Graphics, Controls;

{ Копирует прямоугольную область экрана }

function CaptureScreenRect(ARect : TRect) : TBitmap;

{ Копирование всего экрана }

function CaptureScreen : TBitmap;

{ Копирование клиентской области формы или элемента }

function CaptureClientImage(Control : TControl) : TBitmap;

{ Копирование всей формы элемента }

function CaptureControlImage(Control : TControl) : TBitmap;

implementation

function GetSystemPalette : HPalette;

var

PaletteSize : integer;

LogSize : integer;

LogPalette : PLogPalette;

DC : HDC;

Focus : HWND;

begin

result:=0;

Focus:=GetFocus;

DC:=GetDC(Focus);

try

   PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);

   LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);

   GetMem(LogPalette, LogSize);

   try

     with LogPalette^ do

     begin

       palVersion:=$0300;

       palNumEntries:=PaletteSize;

       GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);

     end;

     result:=CreatePalette(LogPalette^);

   finally

     FreeMem(LogPalette, LogSize);

   end;

finally

   ReleaseDC(Focus, DC);

end;

end;

function CaptureScreenRect(ARect : TRect) : TBitmap;

var

ScreenDC : HDC;

begin

Result:=TBitmap.Create;

with result, ARect do

begin

   Width:=Right-Left;

   Height:=Bottom-Top;

   ScreenDC:=GetDC(0);

   try

     BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );

   finally

     ReleaseDC(0, ScreenDC);

   end;

   Palette:=GetSystemPalette;

end;

end;

function CaptureScreen : TBitmap;

begin

with Screen do

   Result:=CaptureScreenRect(Rect(0,0,Width,Height));

end;

function CaptureClientImage(Control : TControl) : TBitmap;

begin

with Control, Control.ClientOrigin do

   result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));

end;

function CaptureControlImage(Control : TControl) : TBitmap;

begin

with Control do

   if Parent=nil then

     result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))

   else

     with Parent.ClientToScreen(Point(Left, Top)) do

       result:=CaptureScreenRect(Bounds(X,Y,Width,Height));

end;

end.

Code:

// Для копирования изображения, находящегося в клиентской части

// формы есть метод GetFormImage. Для копирования любого

// прямоугольника экрана можно воспользоваться функциями GDI.

// Копирование произвольной прямоугольной области экрана

Function CaptureScreenRect( ARect: TRect ): TBitmap;

var

ScreenDC: HDC;

begin

Result := TBitmap.Create;

with Result, ARect do

begin

   Width := Right - Left;

   Height := Bottom - Top;

   // получаем для экрана контекст устройства

   ScreenDC := GetDC( 0 );

   try

     // копируем оттуда прямоугольную область на канву

     // растрового изображения

     BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,

       Left, Top, SRCCOPY );

   finally

     ReleaseDC( 0, ScreenDC );

   end;

end;

end;

// Таким образом, задавая нужный прямоугольник, можно получить

// изображение любой части экрана, получить изображение любого

// элемента формы(кнопок , выпадающих списков и так далее).

// Пример для копирования нужного элемента формы или всей формы,

// включая и заголовок и рамку:

Function CaptureControlImage( Control: TControl ): TBitmap;

begin

with Control do

   IF Parent = nil Then

     Result := CaptureScreenRect( Bounds( Left, Top, Width,Height ))

   Else

   With Parent.ClientToScreen( Point( Left, Top )) DO

     Result := CaptureScreenRect( Bounds( X, Y, Width,Height ));

end;

Code:

uses

  Graphics;

// Capture the entire screen

procedure ScreenShot(Bild: TBitMap);

var

  c: TCanvas;

  r: TRect;

begin

  c := TCanvas.Create;

  c.Handle := GetWindowDC(GetDesktopWindow);

  try

    r := Rect(0, 0, Screen.Width, Screen.Height);

    Bild.Width := Screen.Width;

    Bild.Height := Screen.Height;

    Bild.Canvas.CopyRect(r, c, r);

  finally

    ReleaseDC(0, c.Handle);

    c.Free;

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

  Form1.Visible := False;

  Sleep(750); // some delay, ein wenig Zeit geben

ScreenShot(Image1.Picture.BitMap);

  Form1.Visible := True;

end;

Code:

// Capture Only active window

procedure ScreenShotActiveWindow(Bild: TBitMap);

var

  c: TCanvas;

  r, t: TRect;

  h: THandle;

begin

  c := TCanvas.Create;

  c.Handle := GetWindowDC(GetDesktopWindow);

  h := GetForeGroundWindow;

  if h <> 0 then

    GetWindowRect(h, t);

  try

    r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);

    Bild.Width  := t.Right - t.Left;

    Bild.Height := t.Bottom - t.Top;

    Bild.Canvas.CopyRect(r, c, t);

  finally

    ReleaseDC(0, c.Handle);

    c.Free;

  end;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

  Form1.Visible := False;

  Sleep(750); //some delay,ein wenig Zeit geben

ScreenShotActiveWindow(Image1.Picture.BitMap);

  Form1.Visible := True;

end;

Code:

// Capture the entire screen

procedure ScreenShot(x: Integer;

  y: Integer; //(x, y) = Left-top coordinate

Width: Integer;

  Height: Integer; //(Width-Height) = Bottom-Right coordinate

bm: TBitMap); //Destination

var

  dc: HDC;

  lpPal: PLOGPALETTE;

begin

  {test width and height}

  if ((Width = 0) or

    (Height = 0)) then

    Exit;

  bm.Width  := Width;

  bm.Height := Height;

  {get the screen dc}

  dc := GetDc(0);

  if (dc = 0) then

    Exit;

  {do we have a palette device?}

  if (GetDeviceCaps(dc, 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(dc,

      0,

      256,

      lpPal^.palPalEntry);

    if (lpPal^.PalNumEntries <> 0) then

      {create the palette}

      bm.Palette := CreatePalette(lpPal^);

    FreeMem(lpPal, SizeOf(TLOGPALETTE) +

    (255 * SizeOf(TPALETTEENTRY)));

  end;

  {copy from the screen to the bitmap}

  BitBlt(bm.Canvas.Handle,

    0,

    0,

    Width,

    Height,

    Dc,

    x,

    y,

    SRCCOPY);

  {release the screen dc}

  ReleaseDc(0, dc);

end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);

begin

ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);

end;

Code:

// Capture a window

procedure ScreenShot(hWindow: HWND; bm: TBitmap);

var

  Left, Top, Width, Height: Word;

  R: TRect;

  dc: HDC;

  lpPal: PLOGPALETTE;

begin

  {Check if valid window handle}

  if not IsWindow(hWindow) then Exit;

  {Retrieves the rectangular coordinates of the specified window}

  GetWindowRect(hWindow, R);

  Left := R.Left;

  Top := R.Top;

  Width := R.Right - R.Left;

  Height := R.Bottom - R.Top;

  bm.Width  := Width;

  bm.Height := Height;

  {get the screen dc}

  dc := GetDc(0);

  if (dc = 0) then

   begin

    Exit;

  end;

  {do we have a palette device?}

  if (GetDeviceCaps(dc, 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(dc,

      0,

      256,

      lpPal^.palPalEntry);

    if (lpPal^.PalNumEntries <> 0) then

     begin

      {create the palette}

      bm.Palette := CreatePalette(lpPal^);

    end;

    FreeMem(lpPal, SizeOf(TLOGPALETTE) +

    (255 * SizeOf(TPALETTEENTRY)));

  end;

  {copy from the screen to the bitmap}

  BitBlt(bm.Canvas.Handle,

    0,

    0,

    Width,

    Height,

    Dc,

    Left,

    Top,

    SRCCOPY);

  {release the screen dc}

  ReleaseDc(0, dc);

end;

// Example: Capture the foreground window:

procedure TForm1.Button1Click(Sender: TObject);

begin

  ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);

end;

Code:

{**********************************************}

// by Daniel Wischnewski

Sometimes you want to take a screen shot,

however often Windows has trouble with big data amounts and becomes very slow.

The simple solution is to make many small screen shots and paste the result together.

It''s not light speed, however often faster than taking the whole screen at once.

const

  cTileSize = 50;

function TForm1.GetSCREENSHOT: TBitmap;

var

  Locked: Boolean;

  X, Y, XS, YS: Integer;

  Canvas: TCanvas;

  R: TRect;

begin

  Result := TBitmap.Create;

  Result.Width := Screen.Width;

  Result.Height := Screen.Height;

  Canvas := TCanvas.Create;

  Canvas.Handle := GetDC(0);

  Locked := Canvas.TryLock;

  try

    XS := Pred(Screen.Width div cTileSize);

    if Screen.Width mod cTileSize > 0 then

      Inc(XS);

    YS := Pred(Screen.Height div cTileSize);

    if Screen.Height mod cTileSize > 0 then

      Inc(YS);

    for X := 0 to XS do

      for Y := 0 to YS do

      begin

        R := Rect(

          X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,

          Succ(Y) * cTileSize);

        Result.Canvas.CopyRect(R, Canvas, R);

      end;

  finally

    if Locked then

      Canvas.Unlock;

    ReleaseDC(0, Canvas.Handle);

    Canvas.Free;

  end;

end;