How to create all sorts of screen shots

Problem/Question/Abstract:

How to create all sorts of screen shots

Answer:

a) Copying the screen content into a form

Solve 1:

procedure TScrnFrm.GrabScreen;
var
  DeskTopDC: HDc;
  DeskTopCanvas: TCanvas;
  DeskTopRect: TRect;
begin
  DeskTopDC := GetWindowDC(GetDeskTopWindow);
  DeskTopCanvas := TCanvas.Create;
  DeskTopCanvas.Handle := DeskTopDC;
  DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height);
  ScrnForm.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect);
  ReleaseDC(GetDeskTopWindow, DeskTopDC);
end;


Solve 2:

{ ... }
var
  Image1: TImage;
  { ... }

procedure TSaverForm.CopyScreen;
var
  DeskTopDC: HDC;
  DeskTopCanvas: TCanvas;
  DeskTopRect: TRect;
begin
  Image1 := TImage.Create(SaverForm);
  with Image1 do
  begin
    Height := Screen.Height;
    Width := Screen.Width;
  end;
  Image1.Canvas.copymode := cmSrcCopy;
  DeskTopDC := GetWindowDC(GetDeskTopWindow);
  DeskTopCanvas := TCanvas.Create;
  DeskTopCanvas.Handle := DeskTopDC;
  Image1.Canvas.CopyRect(Image1.Canvas.ClipRect, DeskTopCanvas, DeskTopCanvas.ClipRect);
  Image2.Picture.Assign(Image1.Picture);
  {image2 is on the saver form, aligned to client}
end;

procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Image1.Free;
end;


b) Copying the screen content into a TImage

Create a form, drop a TImage control to the form, make it a decent size, and drop a button on it. DblClick the button and add the following code.

var
  ScreenDC: HDC;
begin
  ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
  BitBlt(Image1.Canvas.Handle, 0, 0, Image1.Width, Image1.Height, ScreenDC, 0, 0, SRCCOPY);
  Image1.Refresh;
  DeleteDC(ScreenDC);
end;

That will copy the desktop into the Image Control. Play around with the 0,0 near the ScreenDC to move the TopLeft of the image to want to capture. Move your form around and click the button.


c) Copying the screen content into a bitmap

procedure ScreenShot(x: integer; y: integer; Width: integer; Height: integer; bm: TBitmap);
var
  dc: HDC;
  lpPal: PLOGPALETTE;
begin
  {test width and height}
  if ((Width < 1) or (Height < 1)) then
  begin
    exit;
  end;
  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, x, y, SRCCOPY);
  {release the screen dc}
  ReleaseDc(0, dc);
end;


d) Copying the screen content into a memory bitmap

{ ... }
var
  ScreenDC: HDC;
  fBitmap: TBitmap;
begin
  fBitmap := TBitmap.Create;
  fBitmap.Width := 100;
  fBitmap.Height := 100;
  ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
  BitBlt(FBitmap.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, ScreenDC, 0, 0, SRCCOPY);
  { You now have a copy of the screen from (0,0,100,100) in the fBitmap. You now can
  do what you want to it, merge it with another bitmap, or anything else you want to. }
  { Clean Up }
  DeleteDC(ScreenDC);
  fBitmap.Free
end;


e) Various screenshot procedures

unit Scrncap;

interface

uses
  WinTypes, WinProcs, Forms, Classes, Graphics;

function CaptureScreenRect(ARect: TRect): TBitmap;
function CaptureScreen: TBitmap;
function CaptureClientImage(Control: TControl): TBitmap;
function CaptureControlImage(Control: TControl): TBitmap;

implementation

{ Use this to capture a rectangle on the screen }

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;

{ Use this to capture the entire screen }

function CaptureScreen: TBitmap;
begin
  with Screen do
    Result := CaptureScreenRect(Rect(0, 0, Width, Height));
end;

{ Use this to capture just the client area of a form or control...}

function CaptureClientImage(Control: TControl): TBitmap;
begin
  with Control, Control.ClientOrigin do
    Result := CaptureScreenRect(Bounds(X, Y, ClientWidth, ClientHeight));
end;

{ Use this to capture an entire form or control  }

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.