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

Содержание материала

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

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

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

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

в случае успешного скриншота функция вернет True {©Drkb v.3}

Code:

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;

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

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;

Автор Rouse_

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;

Автор: Song

Еще один способ получения скриншота окна, на чистом WinApi:

Code:

function CreateWindwowBitmap(Wnd: HWND): HBITMAP;

{©Drkb v.3}

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;

Автор: Krid

©Drkb::01849

Универсальный способ - скриншот с прозрачностью:

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;

Используйте стандартный Windows API:

используйте hWnd := GetDesktopWindow для получения дескриптора 'рабочего стола';

используйте hDC := GetDC (hWnd) для получения HDC (дескриптора контекста экрана) ;

и не забывайте освобождать (уничтожать дескриптор) hDC после выполнения задачи.

Используя TCanvas.Handle в качестве HDC, можно при помощи WinAPI реализовать функции рисования, или, если это возможно, можно присвоить HDC свойству Handle непосредственно при создании TCanvas.

Разместите на форме TPaintBox и TButton.

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;

Это скопирует верхнюю левую область рабочего стола в верхнюю левую область вашего TPaintBox.

Например, с помощью WinAPI так -

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;

Или с помощью обертки TCanvas -

Объект Screen[.width,height] - размеры

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;

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;

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;

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

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

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

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

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

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;

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;

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,

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,

Width,

Height,

Dc,

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,

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,

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;

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

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

Содержание материала

Новые статьи

Ранние статьи

Случайные статьи

Популярные статьи

Добавить комментарий

Системные функции и WinAPI

Вопросы по Delphi

VCL

Язык Дельфи

Облако тегов

Карта сайта