Come fare uno screenshot con FireMonkey (multipiattaforma)

Question

Non ho trovato una funzione per ottenere uno screenshot in FMX.Platform (comunque, da nessun'altra parte ...).

Con il VCL, ci sono molte risposte (StackOverflow, google, ...).

Ma come ottenere uno screenshot in un'immagine (bitmap o qualsiasi altra cosa) per Windows e Mac OS X?

saluti,

W.

Aggiornamento: Il link from Tipiweb dà una buona soluzione per OS X.

Per quanto riguarda la parte di Windows: ho codificati questo, ma non lo faccio piace usare il VCL e un flusso per ottenerlo ... Qualche suggerimento migliore, commenti?

Grazie.

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

ho costruire una piccola applicazione per prendere screenshot (Windows/Mac) e funziona :-)!

Per compatibilità con Windows e Mac, utilizzo uno stream.

API Mac Capture -> TStream

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

Successivamente, carico il mio Windows o Mac TStream in un FMX.Types.TBitmap (con carico dal flusso)

codice

Unità di 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 Code:

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. 

nella vostra unità mainForm:

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

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

Se avete un'altra idea, per favore parlatemi :-)

Answer 2

È possibile utilizzare una buona soluzione da this site per fare un Mac OSX screenshot.

fare le stesse opere con l'API di Windows in questo modo:

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; 

Dopo di che, sono le unità differenti con:

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

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

Answer 3

Grazie al codice di Tipiweb (nella sua risposta), è stato avviato un progetto github basato su di esso; con alcuni miglioramenti (possibilità di fare uno screenshot solo di una certa finestra, o fare uno screenshot completo).

xscreenshot.pas

L'unità prende il nome (unità singola per tutte le piattaforme)

La pagina del progetto github:

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

Le utilità disponibili in questa unità:

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

I ritocchi finali su MacOS richiedono del lavoro per acquisire uno screenshot di una finestra specifica.

Ancora una volta, grazie a Tipiweb e alla sua risposta per avviare questo progetto.