Cómo tomar una captura de pantalla con FireMonkey (multiplataformas)

Question

No he encontrado una función para obtener una captura de pantalla en FMX.Platform (de todos modos, en ningún otro lugar ...).

Con el VCL, hay muchas respuestas (stackoverflow, google, ...).

Pero, ¿cómo obtener una captura de pantalla en una imagen (mapa de bits o lo que sea) para Windows y Mac OS X?

Saludos,

W.

Actualización: El link from Tipiweb da una buena solución para OS X.

En cuanto a la parte de Windows: He codificados esto, pero no lo hago desea usar el VCL y un Stream para lograrlo ... ¿Alguna sugerencia mejor, comentarios?

Gracias.

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; 

Answer 1

que crear una pequeña aplicación para tomar captura de pantalla (Windows/Mac) y funciona :-) !

Para la compatibilidad con Windows y Mac, utilizo una secuencia.

API Mac Captura -> TStream

API de Windows de captura -> Vcl.Graphics.TBitmap -> TStream.

Después de eso, cargo mi Windows o Mac TStream en FMX.Types.TBitmap (con carga de corriente)

código

Unidad de 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 Código de Unidad:

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. 

En su unidad mainForm:

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

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

Si tiene alguna otra idea, hable conmigo :-)

Answer 2

Se puede utilizar una buena solución de this site hacer una captura de pantalla de Mac OSX.

las mismas obras con la API de Windows como esto:

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; 

Después de eso, incluyen sus diferentes unidades con:

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

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

Answer 3

Gracias al código de Tipiweb (en su respuesta), se ha iniciado un proyecto github basado en él; con algunas mejoras (capacidad de tomar una captura de pantalla solo de una ventana determinada, o tomar una captura de pantalla completa).

xscreenshot.pas

La unidad recibe su nombre (una sola unidad para todas las plataformas)

La página del proyecto github:

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

Las utilidades disponibles en esta unidad:

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

Los toques finales en MacOS necesitan algo de trabajo para tomar una captura de pantalla de una ventana específica.

Nuevamente, gracias a Tipiweb y su respuesta para iniciar este proyecto.