Наконец-то разжился Delphi XE2 и пробую работать с FireMonkey. Довольно интересно, FireMonkey выглядит гибкой штукой. Особенно привлекает кроссплатформенность. Расскажу о том, что успел понять.

Решил начать с простенькой кастомизации компонента, чтобы получше разобраться с тем, как все устроено внутри. Под руку попался TTabControl, мне не хватает «крестика» на каждой вкладке, чтобы их можно было закрывать как в браузере. Очевидно, что наследоваться необходимо от класса TTabItem.

Небольшое лирическое отступление. Вообще, все визуальные компоненты в FireMonkey делятся на две категории: примитивные (наследники TShape) и стилизованные (наследники TStyledControl). Примитивные не делают ничего особо полезного, кроме рисования различных квадратов и окружностей на своей канве, по сути очень напоминая старый добрый TGraphicControl в VCL. А вот стилизованные уже интереснее — они имеют стиль.

Важно отметить, что стиль — это не разноцветная «шкурка», а контрол. Например, стиль TButton состоит из набора прямоугольников, текста и эффектов к ним применяемых. Фактически, говоря в терминах VCL, в FireMonkey любой стилизованный компонент очень похож на фрейм. Т.е. имеет разделенные код и визуальное представление, которое в широких рамках можно менять.

Вернемся к вкладкам TTabControl’а. Довольно интересный для меня момент, что стиль вкладки не имеет ничего общего с её содержимым и описывает всего-лишь саму кнопку. В качестве родителя для компонентов, которые должны на ней располагаться, вкладка использует отдельный контейнер типа TContent. Это позволяет отрисовывать вкладку в два этапа: сначала рисовать кнопку, а затем располагать TContent на теле TTabControl’а-родителя, если эта вкладка активна. За подробностями отсылаю к методам TTabItem.Realign и TTabControl.Realign.

Становится ясно, что добавление «крестика» нужно начать с изменения стиля вкладки. Способ рисования я подсмотрел у TCheckBox и реализовал, добавив в стиль компонент TPath (неплохое описание этого компонента есть тут) с соответствующими свойствами. А также эффект для него, чтобы при наведении курсора «крестик» подсвечивался.

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

Сохраняю измененный стиль в файл ClosableTabItem.style. Текст стиля у меня в итоге получился вот такой, очень похоже на DFM, я не зря сравнил с фреймами :)

object TLayout
  StyleName = 'CloseableTabItemStyle'
  Position.Point = '(276,419)'
  Width = 145.000000000000000000
  Height = 22.000000000000000000
  object TRectangle
    Align = alContents
    Position.Point = '(0,2)'
    Locked = True
    Width = 148.000000000000000000
    Height = 20.000000000000000000
    Padding.Rect = '(0,2,-3,0)'
    HitTest = False
    Fill.Color = xFFEFEFEF
    Stroke.Color = xFF898C95
    Corners = [crTopLeft, crTopRight]
    Sides = [sdTop, sdLeft, sdRight]
    object TRectangle
      Align = alContents
      Width = 148.000000000000000000
      Height = 20.000000000000000000
      HitTest = False
      Fill.Kind = bkGradient
      Fill.Gradient.Points = <
        item
          Color = x24F4F4F4
        end
        item
          Color = x24EAEAEA
          Offset = 0.499000012874603300
        end
        item
          Color = x4E868686
          Offset = 0.500000000000000000
        end>
      Stroke.Color = xC84F4F4F
      Corners = [crTopLeft, crTopRight]
      Sides = [sdTop, sdLeft, sdRight]
      object TFloatAnimation
        Duration = 0.000000999999997475
        Trigger = 'IsSelected=false'
        StopValue = 1.000000000000000000
        PropertyName = 'Opacity'
      end
      object TFloatAnimation
        Duration = 0.000009999999747379
        Trigger = 'IsSelected=true'
        StartValue = 1.000000000000000000
        StopValue = 0.001000000047497451
        PropertyName = 'Opacity'
      end
    end
    object TColorAnimation
      Duration = 0.000009999999747379
      Trigger = 'IsMouseOver=true;IsSelected=false'
      StartValue = xFFEFEFEF
      StopValue = xFFA5D9FF
      PropertyName = 'Fill.Color'
    end
    object TColorAnimation
      Duration = 0.000009999999747379
      Trigger = 'IsMouseOver=false;IsSelected=false'
      StartValue = xFFA5D9FF
      StopValue = xFFEFEFEF
      PropertyName = 'Fill.Color'
    end
    object TColorAnimation
      Duration = 0.000000999999997475
      Trigger = 'IsSelected=false'
      StartValue = xFFFEFEFE
      StopValue = claWhite
      PropertyName = 'Fill.Color'
    end
    object TColorAnimation
      Duration = 0.000009999999747379
      Trigger = 'IsSelected=true'
      StartValue = claWhite
      StopValue = xFFFEFEFE
      PropertyName = 'Fill.Color'
    end
    object TRectAnimation
      Duration = 0.000009999999747379
      Trigger = 'IsSelected=true'
      StartValue.Rect = '(0,2,-1,0)'
      StopValue.Rect = '(0,0,-1,-1)'
      PropertyName = 'Padding'
    end
    object TRectAnimation
      Duration = 0.000009999999747379
      Inverse = True
      Trigger = 'IsSelected=false'
      StartValue.Rect = '(0,2,-1,-1)'
      StopValue.Rect = '(0,0,-1,0)'
      PropertyName = 'Padding'
    end
    object TText
      StyleName = 'text'
      Align = alClient
      Position.Point = '(3,3)'
      Locked = True
      Width = 121.000000000000000000
      Height = 15.000000000000000000
      Padding.Rect = '(3,3,3,2)'
      HitTest = False
      Text = 'item'
      WordWrap = False
    end
    object TPath
      StyleName = 'close'
      Align = alFitRight
      Position.Point = '(132,5)'
      Width = 11.000000000000000000
      Height = 10.000000000000000000
      Padding.Rect = '(5,5,5,5)'
      Data.Path = {
        1200000000000000000000000000000001000000CDCC4C3E0000000001000000
        0000003F9A99993E01000000CDCC4C3F00000000010000000000803F00000000
        010000000000803FCDCC4C3E010000003333333F0000003F010000000000803F
        CDCC4C3F010000000000803F0000803F01000000CDCC4C3F0000803F01000000
        0000003F3333333F01000000CDCC4C3E0000803F01000000000000000000803F
        0100000000000000CDCC4C3F010000009A99993E0000003F0100000000000000
        CDCC4C3E010000000000000000000000030000000000000000000000}
      object TGlowEffect
        Trigger = 'IsMouseOver=true'
        Enabled = False
        Softness = 0.400000005960464400
        GlowColor = claDarkred
        Opacity = 0.899999976158142100
      end
    end
  end
end

Сооветственно, нужен и RC-файл:

ClosableTabItemStyle RCDATA "ClosableTabItem.style"

Теперь, продолжая следовать справке, пишем метод загрузки объекта стиля:

function TClosableTabItem.GetStyleObject: TControl;
var
  S: TResourceStream;
const
  Style = 'ClosableTabItemStyle';
begin
  if (FStyleLookup = '') then
  begin
    if FindRCData(HInstance, Style) then
    begin
      S := TResourceStream.Create(HInstance, Style, RT_RCDATA);
      try
        Result := TControl(CreateObjectFromStream(nil, S));
        Exit;
      finally
        S.Free;
      end;
    end;
  end;
  Result := inherited GetStyleObject;
end;

Вот и все. Почти. Но уже можно писать тестовое приложение. Бросаем на форму TTabControl и кнопку, которая будет добавлять вкладки:

procedure TForm1.Button1Click(Sender: TObject);
var
  NewTab: TClosableTabItem;
begin
  NewTab := TClosableTabItem.Create(TabControl1);
  NewTab.Parent := TabControl1;
  NewTab.Text := 'New Tab';
end;

Кажется, можно запускать. Крестик появился и даже подсвечивается, но ничего полезного не делает :)

Чтобы вкладка смогла закрываться, нужно добавить еще немножко кода. Мелочи вроде объявления переменных FOnCloseQuery и FOnClose опускаю.

Не придумал ничего лучше, чем присваивать обработчик OnClick в момент применения стиля. Судя по коду компонентов FireMonkey, кажется, это вполне нормальная практика.

procedure TClosableTabItem.ApplyStyle;
var
  CloseButton: TfmxObject;
begin
  inherited;
  CloseButton := FindStyleResource('close'); 

  if (CloseButton <> nil) and (CloseButton is TControl) then
    TControl(CloseButton).OnClick := CloseButtonClick;
end;

procedure TClosableTabItem.CloseButtonClick(Sender: TObject);
var
  CanClose: Boolean;
  TabControl: TTabControl;
begin
  CanClose := True;
  if Assigned(FOnCloseQuery) then
    FOnCloseQuery(Self, CanClose);

  if CanClose then
  begin
    if Assigned(FOnClose) then
      FOnClose(Self);

    TabControl := Self.Parent as TTabControl;
    Self.Free;
    TabControl.Realign;
  end;
end;

Простенько, но на данном этапе мне большего и не нужно. Полный код можно скачать здесь.

А теперь плохая новость. В рантайме все работает, но я не нашел никакого способа добавить свой новый тип вкладки в Items Designer. И похоже, что та же самая проблема есть у всех списковых контролов: TListBox, TGrid и т.п. Сначала мне подход к их реализации очень понравился, а вот теперь даже как-то сомневаюсь. Поиск в интернете показал, что я с этой проблемой не одинок.

Справка молчит, в коде я тоже не нашел ничего. Неужели никак? Это было бы крайне неприятно.

update: QC #107177

Связанные записи: