如何在FireMonkey中进行屏幕截图（多平台）

Question

在FMX.Platform中，我没有找到获取屏幕截图的函数（无论在哪里都是如此）。

使用VCL，有很多答案（stackoverflow、google等）。

但是如何在Windows和Mac OS X中获取一个图像（位图或其他）的屏幕截图呢？

谢谢。

W。

更新： Tipiweb提供的链接提供了OS X的好解决方案。

关于Windows部分：我已经编写了代码，但我不想使用VCL和流来实现它......有更好的建议或评论吗？

谢谢。

W。

uses ..., FMX.Types, Winapi.Windows, Vcl.Graphics;

...

function DesktopLeft: Integer;
begin
  Result := GetSystemMetrics(SM_XVIRTUALSCREEN);
end;

function DesktopWidth: Integer;
begin
  Result := GetSystemMetrics(SM_CXVIRTUALSCREEN);
end;

function DesktopTop: Integer;
begin
  Result := GetSystemMetrics(SM_YVIRTUALSCREEN);
end;

function DesktopHeight: Integer;
begin
  Result := GetSystemMetrics(SM_CYVIRTUALSCREEN);
end;


procedure GetScreenShot(var dest: FMX.Types.TBitmap);
var
  cVCL  : Vcl.Graphics.TCanvas;
  bmpVCL: Vcl.Graphics.TBitmap;
  msBmp : TMemoryStream;
begin
  bmpVCL      := Vcl.Graphics.TBitmap.Create;
  cVCL        := Vcl.Graphics.TCanvas.Create;
  cVCL.Handle := GetWindowDC(GetDesktopWindow);
  try
    bmpVCL.Width := DesktopWidth;
    bmpVCL.Height := DesktopHeight;
    bmpVCL.Canvas.CopyRect(Rect(0, 0, DesktopWidth, DesktopHeight),
                           cVCL,
                           Rect(DesktopLeft, DesktopTop, DesktopLeft + DesktopWidth, DesktopTop + DesktopHeight)
                          );
  finally
    ReleaseDC(0, cVCL.Handle);
    cVCL.Free;
  end;

  msBmp := TMemoryStream.Create;
  try
    bmpVCL.SaveToStream(msBmp);
    msBmp.Position := 0;
    dest.LoadFromStream(msBmp);
  finally
    msBmp.Free;
  end;

- Whiler

---

TControl.MakeScreenshot 允许从窗体组件中截取屏幕截图，但在 TScreen 上什么都没有 :( 也不支持监视器... - Whiler

Answer 1

我建立了一个小应用程序来截取屏幕（Windows / Mac），它已经可以正常工作了 :-)！

为了兼容Windows和Mac，我使用了一个流。

API Mac Capture --> TStream

API Windows Capture --> Vcl.Graphics.TBitmap --> TStream.

之后，我使用“从流中加载”将我的Windows或Mac TStream加载到FMX.Types.TBitmap中。 Windows单元代码：

unit tools_WIN;

interface
{$IFDEF MSWINDOWS}
uses Classes {$IFDEF MSWINDOWS} , Windows {$ENDIF}, System.SysUtils, FMX.Types, VCL.Forms, VCL.Graphics;


  procedure TakeScreenshot(Dest: FMX.Types.TBitmap);
{$ENDIF MSWINDOWS}

implementation

{$IFDEF MSWINDOWS}


procedure WriteWindowsToStream(AStream: TStream);
var
  dc: HDC; lpPal : PLOGPALETTE;
  bm: TBitMap;
begin
{test width and height}
  bm := TBitmap.Create;

  bm.Width := Screen.Width;
  bm.Height := Screen.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
    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,Screen.Width,Screen.Height,Dc,0,0,SRCCOPY);

  bm.SaveToStream(AStream);

  FreeAndNil(bm);
  //release the screen dc
  ReleaseDc(0, dc);
end;


procedure TakeScreenshot(Dest: FMX.Types.TBitmap);
var
  Stream: TMemoryStream;
begin
  try
    Stream := TMemoryStream.Create;
    WriteWindowsToStream(Stream);
    Stream.Position := 0;
    Dest.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

{$ENDIF MSWINDOWS}
end.

Mac单元代码：

unit tools_OSX;


interface
{$IFDEF MACOS}
uses

  Macapi.CoreFoundation, Macapi.CocoaTypes, Macapi.CoreGraphics, Macapi.ImageIO,
  FMX.Types,
  system.Classes, system.SysUtils;

  procedure TakeScreenshot(Dest: TBitmap);
{$ENDIF MACOS}

implementation
{$IFDEF MACOS}

{$IF NOT DECLARED(CGRectInfinite)}
const
  CGRectInfinite: CGRect = (origin: (x: -8.98847e+30; y: -8.98847e+307);
    size: (width: 1.79769e+308; height: 1.79769e+308));
{$IFEND}


function PutBytesCallback(Stream: TStream; NewBytes: Pointer;
  Count: LongInt): LongInt; cdecl;
begin
  Result := Stream.Write(NewBytes^, Count);
end;

procedure ReleaseConsumerCallback(Dummy: Pointer); cdecl;
begin
end;

procedure WriteCGImageToStream(const AImage: CGImageRef; AStream: TStream;
  const AType: string = 'public.png'; AOptions: CFDictionaryRef = nil);
var
  Callbacks: CGDataConsumerCallbacks;
  Consumer: CGDataConsumerRef;
  ImageDest: CGImageDestinationRef;
  TypeCF: CFStringRef;
begin
  Callbacks.putBytes := @PutBytesCallback;
  Callbacks.releaseConsumer := ReleaseConsumerCallback;
  ImageDest := nil;
  TypeCF := nil;
  Consumer := CGDataConsumerCreate(AStream, @Callbacks);
  if Consumer = nil then RaiseLastOSError;
  try
    TypeCF := CFStringCreateWithCharactersNoCopy(nil, PChar(AType), Length(AType),
      kCFAllocatorNull); //wrap the Delphi string in a CFString shell
    ImageDest := CGImageDestinationCreateWithDataConsumer(Consumer, TypeCF, 1, AOptions);
    if ImageDest = nil then RaiseLastOSError;
    CGImageDestinationAddImage(ImageDest, AImage, nil);
    if CGImageDestinationFinalize(ImageDest) = 0 then RaiseLastOSError;
  finally
    if ImageDest <> nil then CFRelease(ImageDest);
    if TypeCF <> nil then CFRelease(TypeCF);
    CGDataConsumerRelease(Consumer);
  end;
end;

procedure TakeScreenshot(Dest: TBitmap);
var
  Screenshot: CGImageRef;
  Stream: TMemoryStream;
begin
  Stream := nil;
  ScreenShot := CGWindowListCreateImage(CGRectInfinite,
    kCGWindowListOptionOnScreenOnly, kCGNullWindowID, kCGWindowImageDefault);
  if ScreenShot = nil then RaiseLastOSError;
  try
    Stream := TMemoryStream.Create;
    WriteCGImageToStream(ScreenShot, Stream);
    Stream.Position := 0;
    Dest.LoadFromStream(Stream);
  finally
    CGImageRelease(ScreenShot);
    Stream.Free;
  end;
end;



 {$ENDIF MACOS}
end.

在你的主表单(unit)中：

...
{$IFDEF MSWINDOWS}
  uses tools_WIN;
{$ELSE}
  uses tools_OSX;
{$ENDIF MSWINDOWS}

...
var
  imgDest: TImageControl;
...
TakeScreenshot(imgDest.Bitmap);

如果你有其他想法，请跟我说 :-）

- Tipiweb

---

我宁愿把 ifdef 的用法移动到一个名为 fmx.screenshot 的单元中，然后在应用程序中使用它。否则，在每次需要该功能时都需要进行太多的复制和粘贴。 - ciuly

@ciuly，已经在Github上启动了一个单一的跨平台单元（请参见我的回答），该单元基于Tipiweb的答案中的代码。它还没有完全打磨好，欢迎提出建议（在Github上开放问题）。感谢Tipiweb提供此代码。https://github.com/z505/screenshot-delphi - Another Prog

Answer 2

多亏了Tipiweb的代码（在他的答案中），一个基于此的github项目已经开始；并进行了一些改进（能够仅截取某个窗口的截图，或者截取全屏）。

该单元的名称为xscreenshot.pas（所有平台使用单一单元）。

github项目页面：

• https://github.com/z505/screenshot-delphi

这个单元中可用的工具：

// take screenshot of full screen
procedure TakeScreenshot(...)
// take screenshot only of a specific window
procedure TakeWindowShot(...)

MacOS上的最后一些工作需要进行优化，以便截取特定窗口的屏幕截图。

再次感谢Tipiweb和他的答案，让这个项目得以启动。

- Another Prog

---

请注意，此代码仅适用于单个监视器或具有多个监视器且主监视器位于左侧的系统，因此桌面的左上角为0,0。即使如此，只有主屏幕才会被截屏，因为Screen.Width/Height仅指当前监视器。我目前正在改进代码。 - Mike Dixon

Answer 3

您可以使用此网站提供的良好解决方案来进行Mac OSX的屏幕截图。

使用Windows API执行相同的操作，如下所示：

procedure ScreenShot(x, y, Width, Height: integer; bm: TBitMap);
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
    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;

接下来，使用以下方式包含您的不同单元：

uses
{$IFDEF MSWINDOWS}
   mytools_win,
{$ENDIF MSWINDOWS}

{$IFDEF MACOS}
   mytools_mac,
{$ENDIF MACOS}

- Tipiweb

---

你提到的网站上的OS X源代码非常完美！但是对于Windows来说，因为FMX.Types.TBitmap <> Vcl.Graphics.TBitmap...并且我想使用相同的签名（只有一个参数... FMX.Types.TBitmap），所以你的Windows代码不能直接使用；顺便说一下，+1给OSX！ - Whiler