Снимок экрана

Оформил: DeeCo

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;