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

Delphi , ОС и Железо , Монитор и Экран

Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

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;

Эта программа на языке Delphi предлагает несколько методов для захвата экрана или конкретного окна в виде изображения (биты). Вот подробное описание каждого метода:

Метод 1: Захват всей экранной области

• Процедура ScreenShot захватывает всю рабочую область, включая панель задач.
• Она использует GetWindowDC для получения контекста устройства рабочей области и затем использует BitBlt для копирования содержимого экрана в битовое изображение.

Метод 2: Захват только активного окна

• Процедура ScreenShotActiveWindow захватывает только активное окно (то есть, передний план).
• Она использует GetForeGroundWindow для получения handle активного окна и затем использует GetWindowRect для получения его прямоугольника.
• Остальная часть кода аналогична Методу 1.

Метод 3: Захват конкретного окна

• Процедура ScreenShot захватывает конкретное окно (данное handle).
• Она получает прямоугольник окна с помощью GetWindowRect и затем использует BitBlt для копирования содержимого окна в битовое изображение.

Метод 4: Захват экрана по плиткам

• Этот метод, реализованный функцией GetSCREENSHOT, захватывает экран в виде маленьких плиток (по умолчанию размер 50x50 пикселей) и затем комбинирует их в единое изображение.
• Это подход может быть быстрее, чем захватывать всю экранную область целиком, особенно для больших экранов.
• Однако некоторые методы могут не работать правильно, если целевое окно или рабочая область имеет сложные графики или использует ускорение hardware. Кроме того, некоторые методы могут требовать дополнительных разрешений или привилегий для доступа к определенным окнам или областям системы.

Создание снимка экрана в Delphi: примеры кода для получения снимков всего экрана и активного окна.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Монитор и Экран ::