procedure TScreenGrabber.CaptureMonitor(AFileName: String; AMonitorId: Integer);
var
Rect: TRect;
UsedMonitor: TMonitor;
begin
DebugLn(['Monitor id=', AMonitorId]);
UsedMonitor := Screen.Monitors[AMonitorId];
Rect.Left := UsedMonitor.Left;
Rect.Top := UsedMonitor.Top;
Rect.Width := UsedMonitor.Width;
Rect.Height := UsedMonitor.Height;
CaptureRegion(AFileName, Rect);
end;
procedure TScreenGrabber.CaptureAllMonitors(AFileName: String);
var
Rect: TRect;
begin
Rect.Left := GetSystemMetrics(SM_XVIRTUALSCREEN);
Rect.Top := GetSystemMetrics(SM_YVIRTUALSCREEN);
Rect.Width := GetSystemMetrics(SM_CXVIRTUALSCREEN);
Rect.Height := GetSystemMetrics(SM_CYVIRTUALSCREEN);
CaptureRegion(AFileName, Rect);
end;
procedure TScreenGrabber.CaptureRegion(AFileName: String; ARect: TRect);
{$IfDef Linux}
const
HWND_DESKTOP = 0;
{$EndIf}
var
Bitmap: TBGRABitmap;
Writer: TFPCustomImageWriter;
//GIF: TGIFImage;
ScreenDC: {$IfDef Windows}Windows.{$EndIf}HDC;
begin
DebugLn('Start taking screenshot...');
DebugLn('Region: ', DbgS(ARect));
Bitmap := TBGRABitmap.Create(ARect.Width, ARect.Height, BGRABlack);
//Bitmap.TakeScreenshot(Rect); // Not supports multiply monitors
ScreenDC := GetDC(HWND_DESKTOP); // Get DC for all monitors
DebugLn('ScreenDC=', DbgS(ScreenDC));
{$IfDef Windows}
// https://github.com/artem78/AutoScreenshot/issues/35
// and https://github.com/bgrabitmap/bgrabitmap/issues/200
BitBlt(Bitmap.Canvas.Handle, 0, 0, ARect.Width, ARect.Height,
ScreenDC, ARect.Left, ARect.Top, SRCCOPY);
{$EndIf}
{$IfDef Linux}
// ToDo: Check bug #35 in Linux
Bitmap.LoadFromDevice(ScreenDC, ARect);
{$EndIf}
ReleaseDC(0, ScreenDC);
case ImageFormat of
fmtPNG: // PNG
begin
Writer := TFPWriterPNG.create;
with Writer as TFPWriterPNG do
begin
GrayScale := IsGrayscale;
CompressionLevel := Self.CompressionLevel;
//Indexed := ...;
//UseAlpha := ...;
end;
end;
fmtJPG: // JPEG
begin
Writer := TFPWriterJPEG.Create;
with Writer as TFPWriterJPEG do
begin
CompressionQuality := Quality;
GrayScale := IsGrayscale;
end;
end;
fmtBMP: // Bitmap (BMP)
begin
Writer := TFPWriterBMP.Create;
with Writer as TFPWriterBMP do
begin
BitsPerPixel := Integer(ColorDepth);
//RLECompress := ...;
end;
end;
{fmtGIF: // GIF
begin
GIF := TGIFImage.Create;
try
GIF.Assign(Bitmap);
//GIF.OptimizeColorMap;
GIF.SaveToFile(AFileName);
finally
GIF.Free;
end;
end;}
fmtTIFF:
begin
Writer := TFPWriterTiff.Create;
end;
fmtWEBP:
begin
Writer := TBGRAWriterWebP.Create;
end;
fmtAVIF:
begin
{$IfDef Windows}
// flipped image fix
Bitmap.VerticalFlip();
{$EndIf}
Writer := TBGRAWriterAvif.Create;
end;
end;
try
try
Bitmap.SaveToFile(AFileName, Writer);
except
on E : Exception do
begin
DebugLn('Failed to take screenshot: ', E.ToString);
raise e;
end;
end;
finally
Writer.Free;
Bitmap.Free;
end;
DebugLn('Screenshot saved to ', AFileName);
end;
