Получение изображения экрана

=== Получение изображения экрана ===
// В качестве параметров передаются:
// AHandle - хэндл окна, скриншот которого мы хочем получить
// CompressPercent - процент сжатия картинки
// AImage - картинка, в которую будет помещено изображение
// в случае успешного скриншота функция вернет True
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;
Author: Rouse_
Source: Взято из http://forum.sources.ru
ID: 01847
----
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;
Author: Song
Source: Взято из http://forum.sources.ru
ID: 01848
----
Еще один способ получения скриншота окна, на чистом WinApi:
function CreateWindwowBitmap(Wnd: HWND): HBITMAP;
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;
Author: Krid
Source: Взято из http://forum.sources.ru
ID: 01849
----
Универсальный способ - скриншот с прозрачностью:
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;
Source: http://www.swissdelphicenter.ch
ID: 01850
----
Используйте стандартный Windows API: 
* используйте hWnd := GetDesktopWindow для получения дескриптора 'рабочего стола';
* используйте hDC := GetDC (hWnd) для получения HDC (дескриптора контекста экрана);
и не забывайте освобождать (уничтожать дескриптор) hDC после выполнения задачи. 
Используя TCanvas.Handle в качестве HDC, можно при помощи WinAPI реализовать функции рисования, или, если это возможно, можно присвоить HDC свойству Handle непосредственно при создании TCanvas. 
Source: http://delphiworld.narod.ru/
ID: 01851
----
В D1 (по идее должно работать и в D2) попробуйте это: 
Разместите на форме TPaintBox и TButton. 
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;
Это скопирует верхнюю левую область рабочего стола в верхнюю левую область вашего TPaintBox. 
Source: http://delphiworld.narod.ru/
ID: 01853
----
Например, с помощью WinAPI так -
var
 bmp: TBitmap;
 DC: HDC;
begin
 bmp := TBitmap.Create;
 bmp.Height := Screen.Height;
 bmp.Width := Screen.Width;
 DC := GetDC(0); // Дескриптоp экрана
 BitBlt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
 DC, 0, 0, SRCCOPY);
 bmp.SaveToFile('Screen.bmp');
 ReleaseDC(0, DC);
end;
Или с помощью обертки TCanvas - 
Объект Screen[.width,height] - размеры
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; 
Source: http://delphiworld.narod.ru/
ID: 01854
----
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.
Source: http://delphiworld.narod.ru/
ID: 01855
----
// Для копирования изображения, находящегося в клиентской части
// формы есть метод 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;
Source: http://delphiworld.narod.ru/
ID: 01856
----
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;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01857
----
// 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;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01858
----
// Capture the entire screen
procedure ScreenShot(x, y: Integer; // (x, y) = Left-top coordinate
 Width, 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;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01859
----
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;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01860
----
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.
Its 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;
Author: Daniel Wischnewski
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01861
----