TComboEdit のフォントを変更するサンプルコード

uComboEditHelper.pas

(*
 * TComboEdit のフォントを変更するサンプルコード
 *
 * Copyright (c) 2018 HOSOKAWA Jun.
 *
 * HOW TO USE:
 *   1. Add uComboEditHelper to uses block.
 *   2. Call ComboEdit.SetFont at an appropriate timing such as FormCreate
 *
 * EXAMPLE:
 *   uses
 *     uComboEditHelper;
 *
 *   procedure TForm1.FormCreate(Sender: TObject);
 *   begin
 *     ComboEdit1.SetFont(
 *       '',                  // Empty is Defalut Font
 *       [TFontStyle.fsBold], // Style
 *       30,                  // Size
 *       TAlphaColorRec.Red); // Color
 *   end;
 *
 * LICENSE:
 *   本ソフトウェアは「現状のまま」で、明示であるか暗黙であるかを問わず、
 *   何らの保証もなく提供されます。
 *   本ソフトウェアの使用によって生じるいかなる損害についても、
 *   作者は一切の責任を負わないものとします。
 *
 *   以下の制限に従う限り、商用アプリケーションを含めて、本ソフトウェアを
 *   任意の目的に使用し、自由に改変して再頒布することをすべての人に許可します。
 *
 *   1. 本ソフトウェアの出自について虚偽の表示をしてはなりません。
 *      あなたがオリジナルのソフトウェアを作成したと主張してはなりません。
 *      あなたが本ソフトウェアを製品内で使用する場合、製品の文書に謝辞を入れて
 *      いただければ幸いですが、必須ではありません。
 *
 *   2. ソースを変更した場合は、そのことを明示しなければなりません。
 *      オリジナルのソフトウェアであるという虚偽の表示をしてはなりません。
 *
 *   3. ソースの頒布物から、この表示を削除したり、表示の内容を変更したりしては
 *      なりません。
 *
 *   This software is provided 'as-is', without any express or implied warranty.
 *   In no event will the authors be held liable for any damages arising from
 *   the use of this software.
 *
 *   Permission is granted to anyone to use this software for any purpose,
 *   including commercial applications, and to alter it and redistribute
 *   it freely, subject to the following restrictions:
 *
 *   1. The origin of this software must not be misrepresented;
 *      you must not claim that you wrote the original software.
 *      If you use this software in a product, an acknowledgment in the product
 *      documentation would be appreciated but is not required.
 *
 *   2. Altered source versions must be plainly marked as such,
 *      and must not be misrepresented as being the original software.
 *
 *   3. This notice may not be removed or altered from any source distribution.
 *)

unit uComboEditHelper;

interface

uses
  System.UITypes,
  FMX.Types,
  FMX.ComboEdit,
  FMX.ComboEdit.Style;

type
  TComboEditHelper = class helper for TComboEdit
  private
    function GetEdit: TStyledComboEdit;
    function RemoveFontSettings(
      const Settings: TStyledSettings): TStyledSettings;
    procedure ListBoxApplyStyleLookup(Sender: TObject);
  public
    procedure SetFont(
      const FontFamily: TFontName;
      const FontStyles: TFontStyles;
      const FontSize: Integer;
      const FontColor: TAlphaColor);
  end;

implementation

uses
  System.Rtti,
  System.Generics.Collections,
  FMX.Graphics,
  FMX.Pickers,
  FMX.ListBox;

var
  GFonts: TDictionary<TComboEdit, TTextSettings>;
  GListBoxes: TDictionary<TComboEdit, TCustomListBox>;

type
  TComboTextSettings = class(TTextSettings)
  private var
    [Weak] FComboEdit: TComboEdit;
  public
    constructor Create(const ComboEdit: TComboEdit); reintroduce;
    destructor Destroy; override;
  end;

{ TComboTextSettings }

constructor TComboTextSettings.Create(const ComboEdit: TComboEdit);
begin
  inherited Create(ComboEdit);
  FComboEdit := ComboEdit;
end;

destructor TComboTextSettings.Destroy;
begin
  if GFonts.ContainsKey(FComboEdit) then
    GFonts.Remove(FComboEdit);

  if GListBoxes.ContainsKey(FComboEdit) then
    GListBoxes.Remove(FComboEdit);

  inherited;
end;

{ TComboEditHelper }

function TComboEditHelper.GetEdit: TStyledComboEdit;
var
  i: Integer;
begin
  Result := nil;

  for i := 0 to ChildrenCount - 1 do
    if Children[i] is TStyledComboEdit then
    begin
      Result := TStyledComboEdit(Children[i]);
      Break;
    end;
end;

procedure TComboEditHelper.ListBoxApplyStyleLookup(Sender: TObject);
var
  ListBox: TCustomListBox;
  Edit: TStyledComboEdit;
  Picker: TCustomListPicker;
  Settings: TTextSettings;
  Item: TListBoxItem;
  i: Integer;
begin
  if not GListBoxes.TryGetValue(Self, ListBox) then
    Exit;

  if not GFonts.TryGetValue(Self, Settings) then
    Exit;

  Edit := GetEdit;
  if Edit = nil then
    Exit;

  Picker := Edit.ListPicker;
  if Picker = nil then
    Exit;

  // Font 設定
  for i := 0 to ListBox.Items.Count - 1 do
  begin
    Item := ListBox.ListItems[i];

    Item.StyledSettings := RemoveFontSettings(Item.StyledSettings);

    if Settings.Font.Family <> '' then
      Item.TextSettings.Font.Family := Settings.Font.Family;

    Item.TextSettings.Font.Style := Settings.Font.Style;
    Item.TextSettings.Font.Size := Settings.Font.Size;
    Item.TextSettings.FontColor := Settings.FontColor;
  end;

  // Font Size に応じた Item の高さ調整
  Picker.ItemHeight := Settings.Font.Size + 2;
end;

procedure TComboEditHelper.SetFont(
  const FontFamily: TFontName;
  const FontStyles: TFontStyles;
  const FontSize: Integer;
  const FontColor: TAlphaColor);
var
  Edit: TStyledComboEdit;
  ListBox: TCustomListBox;
  ListBoxPicker: TObject;
  Settings: TTextSettings;
  RttiType: TRttiType;
  RttiField: TRttiField;
begin
  ListBox := nil;

  Edit := GetEdit;
  if Edit = nil then
    Exit;

  RttiType := SharedContext.GetType(Edit.ListPicker.ClassType);
  if (RttiType <> nil) then
  begin
    RttiField := RttiType.GetField('FPopupListPicker');
    if (RttiField <> nil) then
    begin
      ListBoxPicker := RttiField.GetValue(Edit.ListPicker).AsObject;

      if (ListBoxPicker <> nil) then
      begin
        RttiType := SharedContext.GetType(ListBoxPicker.ClassType);
        if (RttiType <> nil) then
        begin
          RttiField := RttiType.GetField('FListBox');
          ListBox := RttiField.GetValue(ListBoxPicker).AsType<TCustomListBox>;
        end;
      end;
    end;
  end;

  if ListBox = nil then
    Exit;

  GListBoxes.Add(Self, ListBox);
  ListBox.OnApplyStyleLookup := ListBoxApplyStyleLookup;

  Settings := TComboTextSettings.Create(Self); // Owner が破棄
  GFonts.Add(Self, Settings);
  Settings.Font.Family := FontFamily;
  Settings.Font.Style := FontStyles;
  Settings.Font.Size := FontSize;
  Settings.FontColor := FontColor;

  Self.StyledSettings := RemoveFontSettings(Self.StyledSettings);
  Self.TextSettings.Assign(Settings);
end;

function TComboEditHelper.RemoveFontSettings(
  const Settings: TStyledSettings): TStyledSettings;
begin
  Result :=
    Settings -
    [
      TStyledSetting.Family,
      TStyledSetting.Size,
      TStyledSetting.Style,
      TStyledSetting.FontColor
    ];
end;

 initialization
  GListBoxes := TDictionary<TComboEdit, TCustomListBox>.Create;
  GFonts := TDictionary<TComboEdit, TTextSettings>.Create;

finalization
  GListBoxes.DisposeOf;
  GFonts.Clear;

end.