Cách chụp ảnh màn hình bằng FireMonkey (đa nền tảng)

Question

Tôi chưa tìm thấy chức năng để có ảnh chụp màn hình trong FMX.Platform (dù sao, không có nơi nào khác ...).

Với VCL, có rất nhiều câu trả lời (stackoverflow, google, ...).

Nhưng cách tải ảnh chụp màn hình trong ảnh (bitmap hoặc bất kỳ thứ gì) cho Windows và Mac OS X?

Kính trọng,

W.

Cập nhật: Các link from Tipiweb đưa ra một giải pháp tốt cho OS X.

Về phần Windows: Tôi đã được mã hóa này, nhưng tôi không muốn sử dụng VCL và Luồng để đạt được nó ... Bất kỳ đề xuất, nhận xét nào tốt hơn?

Cảm ơn.

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

tôi xây dựng một ứng dụng nhỏ để chụp màn hình (Windows/Mac) Và nó hoạt động :-) !

Đối với cửa sổ và khả năng tương thích với Mac, tôi sử dụng luồng.

API Mac Capture -> TStream

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

Sau đó, tôi tải Windows hoặc Mac TStream của mình bằng FMX.Types.TBitmap (có tải trọng từ dòng)

đang

của Windows ĐVT:

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. 

Trong đơn vị MainForm của bạn:

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

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

Nếu bạn có ý tưởng khác, hãy nói chuyện với tôi :-)

Answer 2

Bạn có thể sử dụng một giải pháp tốt từ this site để làm một ảnh chụp màn hình Mac OSX.

Do các công trình tương tự với Windows API như thế này:

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; 

Sau đó, bao gồm các đơn vị khác nhau của bạn với:

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

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

Answer 3

Nhờ mã của Tipiweb (trong câu trả lời), một dự án github đã được bắt đầu dựa trên nó; với một số cải tiến (khả năng chụp ảnh màn hình chỉ của một cửa sổ nhất định hoặc chụp ảnh màn hình đầy đủ).

Các đơn vị được đặt tên xscreenshot.pas (đơn vị duy nhất cho tất cả các nền tảng)

Trang dự án github:

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

Các tiện ích có sẵn trong đơn vị này:

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

Chạm hoàn thiện trên MacOS cần một số công việc để chụp ảnh màn hình của một cửa sổ cụ thể.

Một lần nữa, nhờ Tipiweb và câu trả lời của anh ấy để bắt đầu dự án này.