Mega Code Archive
Getting a screen capture
<![CDATA[
Title: Getting a screen capture
Question: I needed a component which could give me a screen capture of specific coordinates and fullscreen.
Because bitmaps are so large i also wanted to be able to get the capture in JPEG format.
The full source + demo is attached. Check it out!
Answer:
This is the source of the Screencaptureing component:
unit ScreenCapture;
{ **************************************************
* *
* TenKSupport Productions *
* *
* Presents *
* *
* TScreenCapture 1.01 *
* *
**************************************************
* *
* This component can be used with *
* Delphi 2, 3, 4, and 5 *
* *
* If you modify this source then please *
* notify me at j.f.c.ten.klooster@st.hanze.nl *
* *
**************************************************}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, JPEG;
type
TScreenCapture = class(TComponent)
private
FJPEG: Boolean;
FBMP: TBitmap;
FJPG: TJPegImage;
procedure ScreenShot(x, y, Width, Height: integer; bm: TBitMap);
public
Procedure GetScreenShot(X1:Integer=0; X2:integer=0; Y1:integer=0; Y2:integer=0; Fullscreen:boolean=True);
published
Property JPeg:Boolean read FJPEG write FJPEG;
Property Shot1:TBitmap read FBMP write FBMP;
Property Shot2:TJPegImage read FJPG write FJPG;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('TenKSupport', [TScreenCapture]);
end;
{ TScreenCapture }
procedure TScreenCapture.GetScreenShot(X1, X2, Y1, Y2: integer;
Fullscreen: boolean);
var
bm: TBitmap;
begin
bm:=TBitmap.Create;
If FullScreen then
begin
bm.Width := Screen.Width;
bm.Height := Screen.Height;
ScreenShot(0,0,bm.Width, bm.Height, bm);
End
else
begin
bm.Width := X2-X1;
bm.Height := Y2-Y1;
ScreenShot(X1,Y1,bm.Width, bm.Height, bm);
end;
If JPeg then
begin
FJPG:=TJPEGImage.Create;
FJPG.Assign(bm);
End
else
Begin
FBMP:=TBitmap.Create;
FBMP.Assign(bm);
end;
FreeAndNil(BM);
end;
procedure TScreenCapture.ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);
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 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, x, y, SRCCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;
end.
]]>