14Июл

Изменение стиля FireMonkey компонента в RunTime

Posted by: admin Categories: Хард и Софт
Нет комментариев

XE4

Программный доступ к свойствам компонента

IDE FireMonkey предоставляет широкие функциональные возможности для изменения различных свойств компонента (в том числе параметров стиля) во время проектирования. Параметры стиля, также включены в объектные свойства компонента. Но как быть, если объектный код не обеспечивает способ изменить стиль компонента динамически во время выполнения? Многие программисты сталкивались с этой проблемой

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

Исходный код компонента

{******************************************************************************
  Delphi FireMonkey visual component 
******************************************************************************}
unit LineClick;

interface

uses
System.SysUtils, System.Classes, FMX.Types, FMX.Controls, FMX.Objects, System.UIConsts, System.UITypes, System.Types, DrawProperties, System.Rtti, System.Variants, FMX.Forms, FMX.Dialogs, FMX.ExtCtrls, FMX.StdCtrls;

const
  kListPath = 'C:\Windows\Temp\dot.txt';
  kColor    =  TAlphaColor($FF000000) or TAlphaColor($00FFFF);
  kYellow   =  TAlphaColor($FF000000) or TAlphaColor($FFFF00);
  kNullColor=  TAlphaColor($00000000);

type
  TLeftEvent = procedure( Button: TMouseButton;
                          Shift: TShiftState;
                          X, Y: Single;
                          var Z : Boolean  ) of object;
type
  //Subcomponent
  TPens = class(TPersistent)
  private
    { Private declarations }
    FVersion    : String;
    FColor      : TAlphaColor;
    FOnChanged  : TNotifyEvent;

    function    IsColorStored: Boolean;
    function    GetColor: TAlphaColor;
    procedure   SetColor(const Value: TAlphaColor);

  public
    { Public declarations }
    constructor Create;
    procedure   Assign(Source: TPersistent); override;

  published
    { Published declarations }
    property  Version  : String       read FVersion;
    property  Color    : TAlphaColor  read GetColor
                                      write SetColor stored IsColorStored;
    property  OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
end;

type
  TMarkerType   = (Square, Circle);
  TMyFontStyle  = (fsBold, fsItalic, fsStrikeOut) ;
  TMyFontStyles = set of TMyFontStyle;


type
  //Visual Component
  TLineClick = class(TGroupBox)
  private
    { Private declarations }
    List              : TStringList;

    FFocused          : Boolean;           //Boolean property
    FFocusedColor     : TAlphaColor;       //Color property
    FDrawProperties   : TDrawProperties;   //Reference property
    FSet              : TMyFontStyles;     //Set property
    FPointMarkerShape : TMarkerType;       //Enumerated property

  //FPenProperties                         //Exists in non-visual component
    FPenProperties    : TPens;             //Subcomponent property
    FBrush            : TBrush;

    FOrdinal          : Integer;           //Ordinal property
    FCanvasColor      : TAlphaColor;       //Color property

    FIsMarker         : Boolean;
    FClicked          : Boolean;
    LineColor         : TAlphaColor;

    FLeftEvent        : TLeftEvent;        //My event for left button is clicked
    FIsCTRL           : Boolean;           //Will be fired when the left button
                                           //is clicked
    property  OnEnter;
    property  OnExit;

    function  StrBreak(str, Delimeter: string; fromParts, Cnt: Integer) : string;
    procedure SetPointMarkerShape(const Value: TMarkerType);
    procedure SetDrawProperties(const Value: TDrawProperties);
    procedure SetIsMarker(const Value: Boolean);
    procedure SetClicked(const Value: Boolean);
    procedure SetFocusedColor(const Value: TAlphaColor);
    procedure GetHigh(const Value: Integer);
    procedure SetPenProperties(const Value: TPens);
    procedure SetCanvasColor(const Value: TAlphaColor);

  protected
    { Protected declarations }
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure Paint; override;
    procedure DrawDot(Dot1: TPointF; i: Integer = -1);
    procedure EnterEvent(Sender: TObject); dynamic;
    procedure ExitEvent(Sender: TObject); dynamic;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy;                    override;
    procedure   Clear;

  published
    { Published declarations }
    property ResourceLink;
    property OnApplyStyleLookup;
    property Focused         : Boolean         read    FFocused
                                               write   FFocused
                                               stored  TRUE
                                               default False;
    property FocusedColor    : TAlphaColor     read    FFocusedColor
                                               write   SetFocusedColor
                                               stored  TRUE
                                               default kColor;
    property DrawProperties  : TDrawProperties read    FDrawProperties
                                               write   SetDrawProperties;
    property SetTypeProperty : TMyFontStyles   read    FSet
                                               write   FSet
                                               stored  TRUE
                                               default [fsBold];
    property PointMarkerShape: TMarkerType     read    FPointMarkerShape
                                               write   SetPointMarkerShape
                                               stored  TRUE
                                               default TMarkerType.Circle;
    property PenProperties   : TPens           read    FPenProperties
                                               write   SetPenProperties;
    property Ordinal         : Integer         read    FOrdinal
                                               write   GetHigh
                                               stored  TRUE
                                               default 10;
    property Clicked         : Boolean         read    FClicked
                                               write   SetClicked
                                               stored  TRUE
                                               default False;
    property IsMarker        : Boolean         read    FIsMarker
                                               write   SetIsMarker
                                               stored  TRUE
                                               default False;
    //IsCTRL will be fired when the left button is clicked
    property IsCTRL          : Boolean         read    FIsCTRL
                                               stored  TRUE
                                               default False;
    property OnLeftEvent     : TLeftEvent      read    FLeftEvent
                                               write   FLeftEvent;
    property CanvasColor     : TAlphaColor     read    FCanvasColor
                                               write   SetCanvasColor
                                               stored  TRUE
                                               default kYellow;
    procedure ApplyStyle;    override;
end;

//=============================================================================
  implementation
//=============================================================================

{ TPens Subcomponent }

{******************************************************************************
  Constructor
******************************************************************************}
constructor TPens.Create;
begin
  FColor   := TAlphaColorRec.Red;
  FVersion := '1.0';
end;

{******************************************************************************
  Assign
******************************************************************************}
procedure TPens.Assign(Source: TPersistent);
begin
  FColor:= TPens(Source).FColor;
end;

{******************************************************************************
  Getter
******************************************************************************}
function TPens.GetColor: TAlphaColor;
begin
  Result := FColor;
end;

{******************************************************************************
  Is Color Stored flag
******************************************************************************}
function TPens.IsColorStored: Boolean;
begin
  Result:= True;
end;

{******************************************************************************
  Setter (only via Assign)
******************************************************************************}
procedure TPens.SetColor(const Value: TAlphaColor);
begin
  if FColor <> Value then begin
     FColor := Value;
     if Assigned(FOnChanged) then
        FOnChanged(Self);
  end;
end;

{ Visual TLineClick Component  }

{******************************************************************************
  Constructor of visual component
******************************************************************************}
constructor TLineClick.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPenProperties := TPens.Create;
  FBrush         := TBrush.Create(TBrushKind.bkSolid,  FPenProperties.FColor);
  CanFocus       := True;

  List := TStringList.Create();
  if Not FileExists( kListPath ) then
     List.SaveToFile( kListPath );
  List.LoadFromFile( kListPath );

  OnEnter      := EnterEvent;
  OnExit       := ExitEvent;

  //===============================================================
  //Set defaults for props
  //===============================================================
  FFocused          := False               ; //Boolean property
  FFocusedColor     := kColor              ; //Color property
  FSet              := [fsBold]            ; //Set property
  FPointMarkerShape := TMarkerType.Circle  ; //Enumerated property
  FOrdinal          := 10                  ; //Ordinal property

  FClicked          := False               ;
  LineColor         := FFocusedColor       ;
  FIsCTRL           := False               ; //Will be fired when the left button
                                             //is clicked
  FCanvasColor      := kYellow             ; //Color property
  //SetFocus();
  //InvalidateRect( RectF(0, 0, Width, Height) );
  //Self.ApplyStyle;
end;

{******************************************************************************
 String Parser
        str : your string
        Delimeter : Delimeter symbol
        fromParts : Initial position
        Cnt : Number of items
 ShowMessage(StrBreak('test1.test2.test3.test4', '.', 0,1)); //= test1
 ShowMessage(StrBreak('test1.test2.test3.test4', '.', 1,1)); //= test1
 ShowMessage(StrBreak('test1.test2.test3.test4', '.', 2,1)); //= test1
 ShowMessage(StrBreak('test1.test2.test3.test4', '.', 3,1)); //= test4
******************************************************************************}
function TLineClick.StrBreak(str, Delimeter: string; fromParts, Cnt : integer) : string;
var
  StrL : TStringList;
  ParseStr : string;
  i : integer;
begin
  Result := '';
  StrL := TStringList.Create;
  try
    ParseStr:= StringReplace(str, Delimeter, #13, [rfReplaceAll]);
    StrL.Text := ParseStr;

    if StrL.Count > 0 then begin
       for i := 0 to Cnt-1 do
           if (StrL.Count > i) and (StrL.Count > fromParts) then
              if i > 0 then
                 Result := Result + Delimeter + StrL.Strings[fromParts+i]
              else
                 Result := Result + StrL.Strings[fromParts+i];
    end;
  finally
    StrL.Free;
  end;
end;

{******************************************************************************
  Destructor of visual component
******************************************************************************}
destructor TLineClick.Destroy;
begin
  FPenProperties.Free;
  FBrush.Free;
  List.Free;

  inherited Destroy;
end;

{******************************************************************************
  OnMouseUp event dispatcher.

  A control calls MouseUp in response to any of mouse-up messages,
  decoding the message parameters into the shift-key state and position,
  which it passes in the Shift, X and Y parameters, respectively:

  Button determines which mouse button was previously pressed:
    left, right, or middle.
  Shift indicates which shift keys--SHIFT, CTRL, ALT, and CMD
  (only for Mac)--were down when the pressed mouse button is released.
  X and Y are the pixel coordinates of the mouse pointer within the client
  area of the control.

  Override the protected MouseUp method to provide other responses when
  the mouse button previously pressed is released while the cursor is over
  the control.

  We are allowing the user to change CTRL-key default behavior.
******************************************************************************}
procedure TLineClick.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
var
  item  : string;
  iX,iY : Integer;
  fX,fY : Single;
begin
  Inherited MouseUp(Button, Shift, X, Y);

  FClicked := True;

  fX := StrToFloat(Format('%.2f', [X]));
  fY := StrToFloat(Format('%.2f', [Y]));
  iX := Trunc(fX);                      //The Trunc rets Integer part of a Float
  iY := Trunc(fY);

  //We are allowing the user to change CTRL-key default behavior.
  if ssCtrl in Shift then begin
     FIsCTRL     := True;
  end else begin
     FIsCTRL     := False;
  end;

  //if exists the user-handler for event
  if Assigned(FLeftEvent) then
     FLeftEvent( Button, Shift, X, Y, FIsCTRL ); //run user-handler

  if FIsCTRL then begin
     item        := IntToStr(iX) +  '.'  + IntToStr(iY) +  '.'  + '1'
  end else begin
     item        := IntToStr(iX) +  '.'  + IntToStr(iY) +  '.'  + '0'
  end;

  List.Add( item );
  List.SaveToFile( kListPath );

  InvalidateRect( RectF(0, 0, Width, Height) );
end;

{******************************************************************************
  This procedure draws a dot Shape
******************************************************************************}
procedure TLineClick.DrawDot(Dot1: TPointF; i: Integer = -1);
var
  Dot2      : TPointF;
  Fill      : TBrush;
  Stroke    : TStrokeBrush;
  FillColor : TAlphaColor;
begin
    Canvas.Stroke.Thickness := 1;
    Canvas.Stroke.Kind      := TBrushKind.bkSolid;
    Canvas.Stroke.Color     := LineColor;

    Canvas.Fill.Kind        := TBrushKind.bkSolid;
    FillColor               := LineColor;

    //function RectF(Left, Top, Right, Bottom: Single): TRectF;
    Stroke := TStrokeBrush.Create(TBrushKind.bkSolid, LineColor);
    try
      Fill := TBrush.Create(TBrushKind.bkSolid, FillColor);
      try
        if IsMarker then begin
           if PointMarkerShape = Circle then begin
              Canvas.FillEllipse(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)),0.8, Fill  );
              Canvas.DrawEllipse(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)),0.8, Stroke);
           end else begin
              Canvas.FillRect(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)), 0, 0, AllCorners, 0.8, Fill, TCornerType.ctBevel );
              //Canvas.DrawRect(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)), 0, 0, AllCorners, 0.8, TCornerType.ctBevel );
           end;
        end;

        if i >= 0 then begin
           if PointMarkerShape = Circle then begin
              Canvas.FillEllipse(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)),0.8, Fill  );
              Canvas.DrawEllipse(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)),0.8, Stroke);
           end else begin
              Canvas.FillRect(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)), 0, 0, AllCorners, 0.8, Fill, TCornerType.ctBevel );
              //Canvas.DrawRect(RectF( (Dot1.X-3),(Dot1.Y-3),(Dot1.X+3),(Dot1.Y+3)), 0, 0, AllCorners, 0.8, TCornerType.ctBevel );
           end;

           Dot2.X := StrToInt( StrBreak( List.Strings[i-1], '.', 0,1) );
           Dot2.Y := StrToInt( StrBreak( List.Strings[i-1], '.', 1,1) );

           if PointMarkerShape = Circle then begin
              Canvas.FillEllipse(RectF( (Dot2.X-3),(Dot2.Y-3),(Dot2.X+3),(Dot2.Y+3)),0.8, Fill  );
              Canvas.DrawEllipse(RectF( (Dot2.X-3),(Dot2.Y-3),(Dot2.X+3),(Dot2.Y+3)),0.8, Stroke);
           end else begin
              Canvas.FillRect(RectF( (Dot2.X-3),(Dot2.Y-3),(Dot2.X+3),(Dot2.Y+3)), 0, 0, AllCorners, 0.8, Fill, TCornerType.ctBevel );
              //Canvas.DrawRect(RectF( (Dot2.X-3),(Dot2.Y-3),(Dot2.X+3),(Dot2.Y+3)), 0, 0, AllCorners, 0.8, TCornerType.ctBevel );
           end;

           Canvas.DrawLine(Dot1, Dot2, 1.0);
        end;
      finally
        Fill.Free;
      end;
    finally
      Stroke.Free;
    end;
end;

{******************************************************************************
  Paint for Component
******************************************************************************}
procedure TLineClick.Paint;
var
  i          : Integer;
  ctrl       : Boolean;
  Dot1       : TPointF;
//Fill       : TBrush;
begin
  inherited;
  //if not Clicked then exit;
  if List.Count <= 0 then exit;

  //Fill := TBrush.Create(TBrushKind.bkSolid, kYellow);
  //function      RectF( Left, Top,  Right, Bottom: Single): TRectF;
  //Canvas.FillRect(RectF( (10),(10),(Width-10),(Height-10)), 0, 0, AllCorners, 0.8, Fill, TCornerType.ctBevel );

  Dot1.X  := StrToInt( StrBreak( List.Strings[0], '.', 0,1) );
  Dot1.Y  := StrToInt( StrBreak( List.Strings[0], '.', 1,1) );
  DrawDot(Dot1);

  for i := 1 to List.Count-1 do begin
      Dot1.X := StrToInt ( StrBreak( List.Strings[i], '.', 0,1) );
      Dot1.Y := StrToInt ( StrBreak( List.Strings[i], '.', 1,1) );
      ctrl   := StrToBool( StrBreak( List.Strings[i], '.', 2,1) );

      if ctrl then begin
         DrawDot(Dot1, i);
      end else
         DrawDot(Dot1);
  end;
end;

{******************************************************************************
  Setter
******************************************************************************}
procedure TLineClick.SetClicked(const Value: Boolean);
begin
  FClicked := Value;
  SetFocus();
end;

{******************************************************************************
  Setter
******************************************************************************}
procedure TLineClick.SetIsMarker(const Value: Boolean);
begin
  FIsMarker := Value;
  SetFocus();
end;

{******************************************************************************
  Setter
******************************************************************************}
procedure TLineClick.SetDrawProperties(const Value: TDrawProperties);
begin
  FDrawProperties := Value;
  SetFocus();
end;

{******************************************************************************
  Enter Event Handler (is focus)
******************************************************************************}
procedure TLineClick.EnterEvent(Sender: TObject);
begin
  FFocused  := True;
  LineColor := FFocusedColor;
  SetFocus();
end;

{******************************************************************************
  Exit Event Handler (not focus)
******************************************************************************}
procedure TLineClick.ExitEvent(Sender: TObject);
begin
  FFocused := False;
  LineColor := DrawProperties.Brush.Color;
  FClicked := False;

  InvalidateRect( RectF(0, 0, Width, Height) );
end;

{******************************************************************************
  Cleares the dot list
******************************************************************************}
procedure TLineClick.Clear;
begin
  List.Clear;
  List.SaveToFile( kListPath );

  InvalidateRect( RectF(0, 0, Width, Height) );
end;

{******************************************************************************
  Setter
******************************************************************************}
procedure TLineClick.SetFocusedColor(const Value: TAlphaColor);
begin
  LineColor     := Value;
  FFocusedColor := Value;
  SetFocus();
end;

{******************************************************************************
  Setter
******************************************************************************}
procedure TLineClick.SetPointMarkerShape(const Value: TMarkerType);
begin
  FPointMarkerShape := Value;
  SetFocus();
end;

{******************************************************************************
  Getter
******************************************************************************}
procedure TLineClick.GetHigh(const Value: Integer);
begin
  FOrdinal := Succ(Value);
  SetFocus();
end;

{******************************************************************************
  Setter (only via Assign)
******************************************************************************}
procedure TLineClick.SetPenProperties(const Value: TPens);
begin
  FPenProperties.Assign(Value);
  SetFocus();
end;

{******************************************************************************
  Override
******************************************************************************}
procedure TLineClick.ApplyStyle;
var
  T  : TFmxObject;
  s  : string;
  sb : TStyleBook;
begin
  inherited;

  if ResourceLink = nil then
     Exit;

  T := ResourceLink.Root.GetObject;
  if T = nil then
     //ShowMessage( 'ResourceLink.Root.GetObject = nil' )
  else begin
       T := T.FindStyleResource('Visual_Component_Style');
       if T = nil then
          //ShowMessage( 'Visual_Component_Style = nil' )
       else begin
            sb := TStyleBook(T);
            T := sb.Style.FindStyleResource('Rectangle1');
            if T = nil then begin
               //ShowMessage( 'Rectangle1 = nil' );
               Exit;
            end;
       end;
  end;

  if (T <> nil) and (T is TRectangle) then begin
     if TRectangle(T).Fill <> nil then begin
        if (FCanvasColor <> kNullColor)
        then begin
           TRectangle(T).Enabled := True;
           TRectangle(T).Fill.Color := kNullColor;
           TRectangle(T).Fill.Color := FCanvasColor;
           TRectangle(T).Opacity := 0.1;
           TRectangle(T).Enabled := False;
           Self.Repaint;
        end;
      end;
  end;
end;

{******************************************************************************
  Setter
******************************************************************************}
procedure TLineClick.SetCanvasColor(const Value: TAlphaColor);
begin
  FCanvasColor := Value;

  ApplyStyle;
  SetFocus();
end;

//=============================================================================
// EOF
//=============================================================================
end.

Как изменить стиль компонента в RunTime?

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

Цель метода ApplyStyle - найти соответствующий объект стиля и изменить значения свойств компонента: Opacity, Color, Enabled. ApplyStyle ищет нужный ресурс с помощью метода FindStyleResource. При этом на форме приложения, использующего компонент, должна присутствовать соответствующая книга StyleBook. Далее все очень просто — если ресурс стиля найден, то изменение значений нужных свойств уже не является проблемой.

Вместо заключения

Такая работа метода ApplyStyle стала возможна только потому, что целевой компонент имеет уникальное имя стиля — ‘Visual_Component_Style’ и соответствующий ему файл стиля. Тот факт, что код FireMonkey компонента полагается на информацию из файла стилей подразумевает, что редактирование файла стиля может изменить функциональность самого компонента.

Submitted by Sergey Lomako

 ▤  Комета Hyakutake (Хякутакэ)
 ▤  Какими будут АПЛ 5-го поколения
 ▤  Легче алюминия, прочнее стали
 ▤  ПАК ФА против всех