0

Embarcadero Web サイトのサンプルから TRegularPolygon という名前の新しいコンポーネントを作成しました。このコンポーネントは FM1 (XE2) ではうまく機能しますが、XE3 以降では Fill.Color プロパティが応答しません。XE4 および XE5 の設計時にはコンポーネントは黒で塗りつぶされ、実行時にはコンポーネントは白で塗りつぶされます。実行中のプログラムでプログラムによって fill.color プロパティを変更すると、fill.color プロパティが機能します。このコンポーネントは TShape から派生しています。TRectangular や TCircle などの他の Tshape コンポーネントと比較してみましたが、これらのコンポーネントはすべての XEx バージョンでうまく機能します。

コンポーネントのコードは次のとおりです (XE5 用) -->

unit RegularPolygon;

interface

uses
  System.SysUtils, System.Classes, System.Types, System.Math, System.UITypes, FMX.Types, FMX.Controls, FMX.Objects, FMX.Graphics;

type
  TRegularPolygon = class(TShape)
  private
    { Private declarations }
    FNumberOfSides: Integer;
    FPath: TPathData;
    procedure SetNumberOfSides(const Value: Integer);

  protected
    { Protected declarations }
    procedure CreatePath;
    procedure Paint; override;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function PointInObject(X, Y: Single): Boolean; override;

  published
    { Published declarations }
    property NumberOfSides: Integer read FNumberOfSides write SetNumberOfSides;

    property Align;
    property Anchors;
    property ClipChildren default False;
    property ClipParent default False;
    property Cursor default crDefault;
    property DesignVisible default True;
    property DragMode default TDragMode.dmManual;
    property EnableDragHighlight default True;
    property Enabled default True;
    property Fill;
    property Locked default False;
    property Height;
    property HitTest default True;
    property Padding;
    property Opacity;
    property Margins;
    property PopupMenu;
    property Position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property StrokeThickness stored false;
    property StrokeCap stored false;
    property StrokeDash stored false;
    property StrokeJoin stored false;
    property Stroke;
    property Visible default True;
    property Width;


  end;

procedure Register;

////////////////////////////////////////////////////////////////////////////////
implementation

procedure Register;
begin
  RegisterComponents('Shape2', [TRegularPolygon]);
end;

{ TRegularPolygon }

constructor TRegularPolygon.Create(AOwner: TComponent);
begin
  inherited;
  FNumberOfSides := 3;
  FPath := TPathData.Create;
end;

destructor TRegularPolygon.Destroy;
begin
  FreeAndNil(FPath);
  inherited;
end;

procedure TRegularPolygon.SetNumberOfSides(const Value: Integer);
begin
  if (FNumberOfSides <> Value) and (Value >= 3) then
  begin
    FNumberOfSides := Value;
    Repaint;
  end;
end;

procedure TRegularPolygon.CreatePath;
  procedure GoToAVertex(n: Integer; Angle, CircumRadius: Double;
    IsLineTo: Boolean = True);
  var
    NewLocation: TPointF;
  begin
    NewLocation.X := Width  / 2 + Cos(n * Angle) * CircumRadius;
    NewLocation.Y := Height / 2 - Sin(n * Angle) * CircumRadius;

    if IsLineTo then
      FPath.LineTo(NewLocation)
    else
      FPath.MoveTo(NewLocation);
  end;
var
  i: Integer;
  Angle, CircumRadius: Double;
begin
  Angle        := 2 * PI / FNumberOfSides;
  CircumRadius := Min(ShapeRect.Width / 2, ShapeRect.Height / 2);

  // Create a new Path
  FPath.Clear;

  // MoveTo the first point
  GoToAVertex(0, Angle, CircumRadius, False);

  // LineTo each Vertex
  for i := 1 to FNumberOfSides do
    GoToAVertex(i, Angle, CircumRadius);

  FPath.ClosePath;
end;

procedure TRegularPolygon.Paint;
begin
  CreatePath;
  Canvas.FillPath(FPath, AbsoluteOpacity);
  Canvas.DrawPath(FPath, AbsoluteOpacity);
  //Canvas.FillRect(R, XRadius, YRadius, FCorners, AbsoluteOpacity, FFill, CornerType);
  //Canvas.DrawRect(R, XRadius, YRadius, FCorners, AbsoluteOpacity, FStroke, CornerType);
end;

function TRegularPolygon.PointInObject(X, Y: Single): Boolean;
begin
  CreatePath;
  Result := Canvas.PtInPath(AbsoluteToLocal(PointF(X, Y)), FPath);
end;

end.
4

1 に答える 1

1

Fill.color プロパティを機能させる方法を見つけました。通常は TShape によって提供される TBrush (FFill) を再実装し、Paint プロシージャの実装を次のように変更しました。

Canvas.FillPath(FPath, AbsoluteOpacity);

に

Canvas.FillPath(FPath, AbsoluteOpacity, FFill);

新しいコードは次のとおりです。

unit RegularPolygon;

interface

uses
  System.SysUtils, System.Classes, System.Types, System.Math, System.UITypes, FMX.Types, FMX.Controls, FMX.Objects, FMX.Graphics;

type
  TRegularPolygon = class(TShape)
  private
    { Private declarations }
    FNumberOfSides: Integer;
    FPath: TPathData;

    FFill: TBrush;
    procedure SetFill(const Value: TBrush);

    procedure SetNumberOfSides(const Value: Integer);

  protected
    { Protected declarations }
    procedure FillChangedNT(Sender: TObject); virtual;

    procedure CreatePath;
    procedure Paint; override;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function PointInObject(X, Y: Single): Boolean; override;

  published
    { Published declarations }
    property NumberOfSides: Integer read FNumberOfSides write SetNumberOfSides;

    property Align;
    property Anchors;
    property ClipChildren default False;
    property ClipParent default False;
    property Cursor default crDefault;
    property DesignVisible default True;
    property DragMode default TDragMode.dmManual;
    property EnableDragHighlight default True;
    property Enabled default True;
    //property Fill;
    property Fill: TBrush read FFill write SetFill;
    property Locked default False;
    property Height;
    property HitTest default True;
    property Padding;
    property Opacity;
    property Margins;
    property PopupMenu;
    property Position;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property StrokeThickness stored false;
    property StrokeCap stored false;
    property StrokeDash stored false;
    property StrokeJoin stored false;
    property Stroke;
    property Visible default True;
    property Width;


  end;

procedure Register;

////////////////////////////////////////////////////////////////////////////////
implementation

procedure Register;
begin
  RegisterComponents('Shape2', [TRegularPolygon]);
end;

{ TRegularPolygon }

constructor TRegularPolygon.Create(AOwner: TComponent);
begin
  inherited;

  FFill := TBrush.Create(TBrushKind.bkSolid, $FFE0E0E0);
  FFill.OnChanged := FillChanged;
  //FStroke := TStrokeBrush.Create(TBrushKind.bkSolid, $FF000000);
  //FStroke.OnChanged := StrokeChanged;

  FNumberOfSides := 3;
  FPath := TPathData.Create;
end;

destructor TRegularPolygon.Destroy;
begin
  //FStroke.Free;
  FFill.Free;

  FreeAndNil(FPath);
  inherited;
end;

procedure TRegularPolygon.FillChangedNT(Sender: TObject);
begin
  if FUpdating = 0 then
    Repaint;
end;

procedure TRegularPolygon.SetFill(const Value: TBrush);
begin
  FFill.Assign(Value);
end;

procedure TRegularPolygon.SetNumberOfSides(const Value: Integer);
begin
  if (FNumberOfSides <> Value) and (Value >= 3) then
  begin
    FNumberOfSides := Value;
    Repaint;
  end;
end;

procedure TRegularPolygon.CreatePath;
  procedure GoToAVertex(n: Integer; Angle, CircumRadius: Double;
    IsLineTo: Boolean = True);
  var
    NewLocation: TPointF;
  begin
    NewLocation.X := Width  / 2 + Cos(n * Angle) * CircumRadius;
    NewLocation.Y := Height / 2 - Sin(n * Angle) * CircumRadius;

    if IsLineTo then
      FPath.LineTo(NewLocation)
    else
      FPath.MoveTo(NewLocation);
  end;
var
  i: Integer;
  Angle, CircumRadius: Double;
begin
  Angle        := 2 * PI / FNumberOfSides;
  CircumRadius := Min(ShapeRect.Width / 2, ShapeRect.Height / 2);

  // Create a new Path
  FPath.Clear;

  // MoveTo the first point
  GoToAVertex(0, Angle, CircumRadius, False);

  // LineTo each Vertex
  for i := 1 to FNumberOfSides do
    GoToAVertex(i, Angle, CircumRadius);

  FPath.ClosePath;
end;

procedure TRegularPolygon.Paint;
begin
  CreatePath;

  Canvas.FillPath(FPath, AbsoluteOpacity, FFill);
  Canvas.DrawPath(FPath, AbsoluteOpacity);
  //Canvas.DrawPath(FPath, AbsoluteOpacity, FStroke);

end;

function TRegularPolygon.PointInObject(X, Y: Single): Boolean;
begin
  CreatePath;
  Result := Canvas.PtInPath(AbsoluteToLocal(PointF(X, Y)), FPath);
end;

end.
于 2013-10-08T03:55:25.923 に答える