// В качестве параметров передаются:
// 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.;
  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;

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;

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.;

 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;

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

procedure TForm1.Button1Click(Sender: TObject);

var

 Desk: TCanvas;

begin

 Desk := TCanvas.Create;

 try

  with Desk do

  Handle := GetWindowDC(GetDesktopWindow);

  with PaintBox1.Canvas do

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

  Desk,

  Rect(0, 0, 200, 200))

 finally

  Desk.Free;

 end

end;

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;

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;

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-;
  ScreenDC:=GetDC(0);
  try
  BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, , 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,,Width,Height))
  else
  with Parent.ClientToScreen(Point(Left, )) do
  result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.

// Для копирования изображения, находящегося в клиентской части
// формы есть метод GetFormImage. Для копирования любого
// прямоугольника экрана можно воспользоваться функциями GDI.
// Копирование произвольной прямоугольной области экрана
Function CaptureScreenRect( ARect: TRect ): TBitmap;
var
 ScreenDC: HDC;
begin
 Result := TBitmap.Create;
 with Result, ARect do
 begin
  Width := Right - Left;
  Height := Bottom - ;
  // получаем для экрана контекст устройства
  ScreenDC := GetDC( 0 );
  try
  // копируем оттуда прямоугольную область на канву
  // растрового изображения
  BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,
  Left, , 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, , Width,Height ))
  Else
  With Parent.ClientToScreen( Point( Left,  )) DO
  Result := CaptureScreenRect( Bounds( X, Y, Width,Height ));
end;

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;

// 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.);
  Bild.Width := t.Right - t.Left;
  Bild.Height := t.Bottom - t.;
  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;

// 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;

// Capture a window
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
 var
  Left, , 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;
   := R.;
  Width := R.Right - R.Left;
  Height := R.Bottom - R.;
  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,
  ,
  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;

{**********************************************}
 // 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;