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

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
;

Другое по теме:

• Вырубить монитор
• Как копировать образ экрана в файл
• Как написать приложение, адекватно отображающееся на экранах с различным разрешением монитора