Создание компонентов в FireMonkey на примере кнопки с картинкой

В среде Delphi постоянно приходиться использовать визуальные компоненты, и для различных задач создаются собственные. Каждый графический элемент (TStyledControl) использует какие либо стили: собственные или других элементов, даже сам может выступать в качестве стиля.

И так в этой статье попробуем разобраться как собрать свой компонент для FireMonkey.

Данная статься подразумевает что читатель уже знаком с технологией FMX, стилями и как устроены компоненты.

В FireMonkey у стилизованного компонента есть вариации использования стилей, т.е создать собственный стиль для компонента со своим функционалом, либо использовать стандартный стиль другого компонента. Для данного компонента можно использовать следующий стиль, который состоит из простых графических элементов

а также использовать стандартный стиль кнопки с модификацией. При применении самого стиля в методе ApplyStyle, мы подставим обычный TImage со своими свойствами и настройками

Для выравнивания расположения картинки внутри кнопки введем новый тип TBitmapAlign

 TBitmapAlign = (alLeft, alRight, alTop, alBottom, alCenter, alContents);

Данный компонент будет наследоваться от обычного TButton и структура его будет следующая

 TgcButton = class(TButton)
  private
    FBitmap: TBitmap; //контейнер для изображения
    FImage: TImage;
    FBitmapAlign: TBitmapAlign; //выравниваем Image
    FBitmapSize: Single;
    FBitmapMargins: TBounds; //отступы
    FBitmapLookup: string;
    procedure SetBitmap(const Value: TBitmap);
    procedure SetBitmapLayout(const Value: TBitmapAlign);
    procedure SetBitmapSize(const Value: Single);
    procedure SetBitmapMargins(const Value: TBounds);
    procedure SetBitmapLookup(const Value: string);
    procedure DoBitmapMarginsChange(Sender: TObject);
    procedure DoBitmapChanged(Sender: TObject);
  protected
   //используем стандартный стиль buttonstyle
    function GetDefaultStyleLookupName: string; override;
    procedure ApplyStyle; override;
    procedure FreeStyle; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property BitmapAlign: TBitmapAlign read FBitmapAlign write SetBitmapLayout default TBitmapAlign.alLeft;
    property BitmapSize: Single read FBitmapSize write SetBitmapSize;
    property BitmapMargins: TBounds read FBitmapMargins write SetBitmapMargins;
    property BitmapLookup: string read FBitmapLookup write SetBitmapLookup;
  end;

Структура получилась вполне простая и стандартная, что разобраться в ней не составит особого труда.

Реализация компонента TgcButton будет следующей

procedure TgcButton.ApplyStyle;
Var
 B: TFmxObject;
 Img: TImage;
begin
  inherited;
  B := FindStyleResource('image');
  if Assigned(B) and (B is TImage) then
    Img := TImage(B) //используем Image из стиля 
   else Img := FImage; //используем свой Image

  B := FindStyleResource('text');
  if Assigned(B) and (B is TText) then
  begin
    Img.Parent := TText(B).Parent; //расположимся там же где и текст
    Img.Align := TAlignLayout.alNone;
  end;

 if not FBitmapLookup.IsEmpty then
  Img.Bitmap.StyleLookup := FBitmapLookup //используем ресурс изображения
  else
   Img.Bitmap := FBitmap; //используем из контейнера

  Img.Margins.Assign(FBitmapMargins);

 if FBitmap.IsEmpty and FBitmapLookup.IsEmpty then
  Img.Align := TAlignLayout.alNone
 else
  case FBitmapAlign of
    alLeft:
     begin
      Img.Align := TAlignLayout.alLeft;
      Img.Width := FBitmapSize;
     end;
    alRight:
     begin
      Img.Align := TAlignLayout.alRight;
      Img.Width := FBitmapSize;
     end;
    alTop:
     begin
      Img.Align := TAlignLayout.alTop;
      Img.Height := FBitmapSize;
     end;
    alBottom:
     begin
      Img.Align := TAlignLayout.alBottom;
      Img.Height := FBitmapSize;
     end;
    alCenter:
     begin
      Img.Align := TAlignLayout.alCenter;
      Img.Width := FBitmapSize;
      Img.Height := FBitmapSize;
     end;
    alContents:
      Img.Align := TAlignLayout.alContents;
  end;
end;

procedure TgcButton.FreeStyle;
begin
  FImage.Parent := nil;
  inherited;
end;

constructor TgcButton.Create(AOwner: TComponent);
begin
  inherited;
  Height := 33;
  Width := 100;

  FBitmap := TBitmap.Create(0,0);
  FBitmap.OnChange := DoBitmapChanged;

  FBitmapSize := 32;

  FBitmapMargins :=  TBounds.Create(RectF(2,2,2,2));
  FBitmapMargins.OnChange := DoBitmapMarginsChange;

  FBitmapLookup := '';
  FBitmapAlign := TBitmapAlign.alLeft;

  FImage := TImage.Create(Self);
  FImage.Stored := False;
  FImage.HitTest := False;
  FImage.Locked := True;
end;

destructor TgcButton.Destroy;
begin
  if Assigned(FBitmap) then
   FreeAndNil(FBitmap);
  if Assigned(FImage) then
   FreeAndNil(FImage);
  FreeAndNil(FBitmapMargins);
  inherited;
end;

procedure TgcButton.DoBitmapChanged(Sender: TObject);
begin
 Repaint;
 ApplyStyle;
end;

procedure TgcButton.DoBitmapMarginsChange(Sender: TObject);
begin
 if not (csLoading in ComponentState) then
   ApplyStyle;
end;

function TgcButton.GetDefaultStyleLookupName: string;
begin
 Result := 'buttonstyle';
end;

procedure TgcButton.SetBitmap(const Value: TBitmap);
begin
 FBitmap.Assign(Value);
end;

procedure TgcButton.SetBitmapLayout(const Value: TBitmapAlign);
begin
 if FBitmapAlign <> Value then
  begin
    FBitmapAlign := Value;
    ApplyStyle;
  end;
end;

procedure TgcButton.SetBitmapMargins(const Value: TBounds);
begin
 FBitmapMargins.Assign(Value);
end;

procedure TgcButton.SetBitmapSize(const Value: single);
begin
if FBitmapSize <> Value then
  begin
    FBitmapSize := Value;
    if not (csLoading in ComponentState) then
      ApplyStyle;
  end;
end;

procedure TgcButton.SetBitmapLookup(const Value: string);
begin
 if FBitmapLookup <> Value then
  begin
   FBitmapLookup := Value;
   ApplyStyle;
  end;
end;

Вот и все, компонент полностью реализован, осталось его зарегистрировать, установить и использовать в своих проектах. 

Вот так выглядит результат работы компонента в программе

Исходный код проекта: gControlsXE4.7z