Создание кроссплатформенного сервиса на примере снимка экрана

Создание программы для различных платформ подразумевает написание исходников для каждой платформы, и чтобы не запутаться, мы будем использовать сервисы.  Реализация сервисов в FireMonkey2.0 представляет собой интерфейс, который описывает шаблон класса или объекта для каждой платформы (Win32, Win64, MacOSX).

Для этого нам потребуется создать 3 новых модуля:

  • FMX.Desktop.pas - главный модуль сервиса
  • FMX.Desktop.Win.pas - реализация под Windows
  • FMX.Desktop.Mac.pas - реализация под MacOSX

 

Главный модуль FMX.Desktop

FMX.Desktop будет являться главным модулем для интерфейса и класса TDesktop, использующий наш сервис, его реализацию мы рассмотрим чуть позже.

Используем следующие модули:
uses
  FMX.Types, FMX.Forms, System.Types;

 

Опишем наш сервис, он будет включать в себя одну процедуру, которая реализует снимок области экрана и помещает его Bitmap
type 
 IFMXDesktopService = interface
  ['{8F373EDD-7FFB-4F36-B4E9-0E2D8787BD7A}']
    procedure CaptureScreen(Dest: TBitmap; const ARect: TRect);
 end;

Примечание: для генерации GUID используем комбинацию клавиш Ctrl + Shift + G

 

Реализация сервиса под Windows (FMX.Desktop.Win)

TWinDesktopService - интерфейсный класс использующий IFMXDesktopService и его структура для Windows платформы будет следующая
type
 TWinDesktopService = class(TInterfacedObject, IFMXDesktopService)
  private
   procedure CaptureScreenToStream(AStream: TStream; ARect: TRect);
  public
   {IFMXDesktopService}
   procedure CaptureScreen(Dest: TBitmap; const ARect: TRect);
  end;

Реализация функционала 

uses
 Winapi.Windows, VCL.Graphics;

{ TWinDesktopService }

procedure TWinDesktopService.CaptureScreen(Dest: FMX.Types.TBitmap; const ARect: TRect);
var
 S: TMemoryStream;
begin
 if not Assigned(Dest) then Exit;

 S := TMemoryStream.Create;
 try
  CaptureScreenToStream(S, ARect);
  S.Position := 0;
  Dest.LoadFromStream(S);
 finally
  S.Free;
 end;
end;

procedure TWinDesktopService.CaptureScreenToStream(AStream: TStream; ARect: TRect);
var
 DC: HDC;
 P: PLOGPALETTE;
 B: TBitmap;
begin
 //получаем дескриптор экрана
 DC := GetDC(0);
 if (DC = 0) then exit;

 B := TBitmap.Create;
 try
  B.Width := ARect.Width;
  B.Height := ARect.Height;
 //проверяем содержит устройство палитру
  if (GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE = RC_PALETTE) then
  begin
    //выделяем память
    GetMem(P,  SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    //заполняем нулями
    FillChar(P^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)), #0);
    P^.palVersion := $300;
    //считываем записи системной палитры
    P^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, P^.palPalEntry);

    if (P^.PalNumEntries <> 0) then
     B.Palette := CreatePalette(P^); //создаем палитру и устанавливаем нашему битмапу

    FreeMem(P, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
  end;
  //копируем содержимое экрана в Bitmap
  BitBlt(B.Canvas.Handle, 0, 0, B.Width, B.Height, DC, ARect.Left, ARect.Top, SRCCOPY);

  B.SaveToStream(AStream);
 finally
  FreeAndNil(B);
   //очищаем дескриптор экрана
  ReleaseDC(0, DC);
 end;
end;

После того как сервис реализован мы можем его зарегистрировать используя секцию инициализации 

initialization
  TPlatformServices.Current.AddPlatformService(IFMXDesktopService, TWinDesktopService.Create);

 

Реализация сервиса под MacOSX (FMX.Desktop.Mac)

Опишем структуру для MacOSX сервиса, для этого на потребуются следующие дополнительные MacApi модули
uses
  Macapi.CoreFoundation, Macapi.CocoaTypes, Macapi.CoreGraphics, Macapi.ImageIO;

 

type
 TMacDesktopService = class(TInterfacedObject, IFMXDesktopService)
  private
    procedure WriteCGImageToStream(const AImage: CGImageRef; AStream: TStream;
       const AType: string = 'public.png'; AOptions: CFDictionaryRef = nil);
  public
   {IFMXDesktopService}
    procedure CaptureScreen(Dest: TBitmap; const ARect: TRect);
  end;

Реализация функционала 

implementation

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

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

{ TMacDesktopService }

procedure TMacDesktopService.CaptureScreen(Dest: TBitmap; const ARect: TRect);
var
  Screenshot: CGImageRef;
  Stream: TMemoryStream;
  R: NSRect;
begin
  if not Assigned(Dest) then Exit;

  with ARect do
   R := MakeNSRect(Left, Top, Width, Height);

  ScreenShot := CGWindowListCreateImage(R,kCGWindowListOptionOnScreenOnly,
    kCGNullWindowID, kCGWindowImageDefault);

  if ScreenShot = nil then
    RaiseLastOSError;

  Stream := TMemoryStream.Create;
  try
    WriteCGImageToStream(ScreenShot, Stream);
    Stream.Position := 0;
    Dest.LoadFromStream(Stream);
  finally
    CGImageRelease(ScreenShot);
    Stream.Free;
  end;
end;

procedure TMacDesktopService.WriteCGImageToStream(const AImage: CGImageRef;
  AStream: TStream; const AType: string; AOptions: CFDictionaryRef);
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), AType.Length, kCFAllocatorNull);
    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;

Также регистрируем наш сервис 

initialization
 TPlatformServices.Current.AddPlatformService(IFMXDesktopService, TMacDesktopService.Create);

 

Реализуем класс-обертку, который будет проще использовать в любом проекте, а также в дальнейшем его поддержку и расширяемость. TDesktop включает в себя не классовую перегруженную(overload) процедуру(CaptureScreen), которая может быть вызвана без создания самого класса.

 TDesktop = class sealed
 public 
  class procedure CaptureScreen(Dest: TBitmap); overload;
  class procedure CaptureScreen(Dest: TBitmap; const ARect: TRect); overload;
 end;

{ TDesktop }

class procedure TDesktop.CaptureScreen(Dest: TBitmap; const ARect: TRect);
var
 DS: IFMXDesktopService;
begin
 TPlatformServices.Current.SupportsPlatformService(IFMXDesktopService, IInterface(DS));
 if Assigned(DS) then
  DS.CaptureScreen(Dest, ARect);
end;

class procedure TDesktop.CaptureScreen(Dest: TBitmap);
begin
 with Screen do
  CaptureScreen(Dest, Rect(0, 0, Size.cx, Size.cy));
end;

Для использования нескольких модулей для различных платформ в одной программе включем директивы условной компиляции 

uses
 FMX.Platform
{$IFDEF MSWINDOWS}
  , FMX.Desktop.Win
{$ELSE}
  {$IFDEF MACOS}
  , FMX.Desktop.Mac
  {$ENDIF MACOS}
{$ENDIF MSWINDOWS};

 

После того как наши модули готовы, попробуем использовать их в программе и оценить работу для каждой платформы, для этого в наш проект добавим FMX.Desktop, а вызовы будем осуществлять через класс-обертку TDesktop

procedure TMainForm.Button1Click(Sender: TObject);
var
 R: TRect;
begin
//делаем скрин определенной области
  R := Rect(100,50,640,480);
  TDesktop.CaptureScreen(Image1.Bitmap, R);

//скрин нашего окна приложения
//R := Rect(Left, Top, Left + Width, Top + Height);
//TDesktop.CaptureScreen(Image1.Bitmap, R);

//скрин целого экрана
//TDesktop.CaptureScreen(Image1.Bitmap);
end;

    

Исходный код модулей: DesktopService.7z

Полезные ссылки: