whats new ¦  programming tips ¦  indy articles ¦  intraweb articles ¦  informations ¦  links ¦  interviews
 misc ¦  tutorials ¦  Add&Win Game

Tips (1541)

Database (90)
Files (137)
Forms (107)
Graphic (114)
IDE (21)
Indy (5)
Internet / LAN (130)
IntraWeb (0)
Math (76)
Misc (126)
Multimedia (45)
Objects/
ActiveX (51)

OpenTools API (3)
Printing (35)
Strings (83)
System (266)
VCL (242)

Top15

Tips sort by
component


Search Tip

Add new Tip

Add&Win Game

Advertising

32 Visitors Online


 
...capture the screen?
Autor: Rainer Kümmerle
Homepage: http://www.thinklazy.de
[ Print tip ]  

Tip Rating (105):  
     


uses
  Graphics;

// Capture the entire screen
// Screenshot des gesamten Bildschirms
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;


// Only active window
// Screenshot des aktiven Fensters
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;

{**********************************************}
// Another print screen function by Xavier P:
// 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, 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;


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

 

Rate this tip:

poor
very good


Copyright © by SwissDelphiCenter.ch
All trademarks are the sole property of their respective owners