How to take a screenshot with FireMonkey (multi-platforms) - delphi

Question

I haven't find a function to get a screenshot in FMX.Platform (anyway, nowhere else...).
With the VCL, there are many answers (stackoverflow, google, ...).
But how to get a screenshot in an image(bitmap or whatever) for Windows and Mac OS X?
Regards,
W.
Update:
The link from Tipiweb gives a good solution for OS X.
Regarding the Windows part: I have coded this, but I don't like to use the VCL, and a Stream to achieve it...
Any better suggestion, comments?
Thanks.
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

I build a small application to take screenshot (Windows / Mac) and it works :-) !
For windows and Mac compatibility, I use a stream.
API Mac Capture --> TStream
API Windows Capture --> Vcl.Graphics.TBitmap --> TStream.
After that, I load my Windows or Mac TStream in a FMX.Types.TBitmap (with load from stream)
Windows Unit code :
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.
In your mainForm unit :
...
{$IFDEF MSWINDOWS}
uses tools_WIN;
{$ELSE}
uses tools_OSX;
{$ENDIF MSWINDOWS}
...
var
imgDest: TImageControl;
...
TakeScreenshot(imgDest.Bitmap);
If you have another idea, please talk to me :-)

Answer 2

Thanks to Tipiweb's code (in his answer), a github project has been started based on it; with some improvements (ability to take a screenshot only of a certain window, or take a full screenshot).
The unit is named xscreenshot.pas (single unit for all platforms)
The github project page:
https://github.com/z505/screenshot-delphi
The utilities available in this unit:
// take screenshot of full screen
procedure TakeScreenshot(...)
// take screenshot only of a specific window
procedure TakeWindowShot(...)
Finishing touches on MacOS need some work for taking a screenshot of a specific window.
Again, thanks to Tipiweb and his answer to get this project started.

Answer 3

You can use a good solution from this site to do a Mac OSX screenshot.
Do the same works with the Windows API like this:
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;
After that, include your different units with:
uses
{$IFDEF MSWINDOWS}
mytools_win,
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
mytools_mac,
{$ENDIF MACOS}