Gauge in Firemonkey

[CHackbart]

Ich habe das jetzt wie folgt abgeändert:

Delphi-Quellcode:

unit UGauge;

interface

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

type
  TGauge = class(TControl)
  protected
    FScale: single;
    FBitmap: TBitmap;
    FBackColor: TAlphaColor;
    FDialColor: TAlphaColor;
    FForeColor: TAlphaColor;
    FFlatMode: Boolean;
    FForceUpdate: Boolean;

    FGlossAlpha: Byte;

    FCurrentValue: single;
    FThreshHold: single;
    FCaptureThresh: Boolean;
    FMaxValue: single;
    FMinValue: single;

    FToAngle: single;
    FFromAngle: single;

    FNoOfDivisions: integer;
    FNoOfSubDivisions: integer;

    FGaugeName: String;

    procedure SetFlatMode(const Value: Boolean);

    procedure DrawBackground(const Canvas: TCanvas; const RealWidth, Width, Height: single;
      const Center: TPointF);
    procedure DrawCenterPoint(const Canvas: TCanvas; const Width: single;
      const Center: TPointF);
    procedure DrawCallibration(const Canvas: TCanvas; const Width: single;
      const Center: TPointF);
    procedure DrawPointer(const Canvas: TCanvas; const Width: single;
      const Center: TPointF; const Thresh: Boolean = false);
    procedure DrawGloss(const Canvas: TCanvas; const Width: single;
      const Center: TPointF);

    procedure SetCurrentValue(const Value: single);

    procedure Paint; override;
    procedure Resize; override;

    procedure RenderBackground(const Width, Height: single);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure ResetThreshold;

    property BackColor: TAlphaColor read FBackColor write FBackColor;
    property ForeColor: TAlphaColor read FForeColor write FForeColor;
    property DialColor: TAlphaColor read FDialColor write FDialColor;
    property GlossAlpha: Byte read FGlossAlpha write FGlossAlpha;
    property CurrentValue: single read FCurrentValue write SetCurrentValue;
    property MaxValue: single read FMaxValue write FMaxValue;
    property MinValue: single read FMinValue write FMinValue;
    property ToAngle: single read FToAngle write FToAngle;
    property FromAngle: single read FFromAngle write FFromAngle;
    property noOfDivisions: integer read FNoOfDivisions write FNoOfDivisions;
    property noOfSubDivisions: integer read FNoOfSubDivisions
      write FNoOfSubDivisions;
    property GaugeName: String read FGaugeName write FGaugeName;
    property CaptureThresh: Boolean read FCaptureThresh write FCaptureThresh;

    property FlatMode: Boolean read FFlatMode write SetFlatMode;
  published
    property Align;
    property Anchors;
    property ClipChildren default false;
    property ClipParent default false;
    property DesignVisible default True;
    property Enabled default True;
    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 Visible default True;
    property Width;
    { Mouse events }
    property OnClick;
    property OnDblClick;

    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;

    property OnPainting;
    property OnPaint;
    property OnResize;
  end;

implementation

uses FMX.Platform;

{ TGauge }
constructor TGauge.Create(AOwner: TComponent);
var
  ScreenSvc: IFMXScreenService;
begin
  inherited;
  FBitmap := TBitmap.Create;
{$IFDEF ANDROID}
  FFlatMode := True;
{$ENDIF}

  FBackColor := $FF000080;
  FDialColor := $FFE6E6FA;
  FForeColor := $FF000000;

  MaxValue := 100;
  MinValue := 0;
  CurrentValue := 0;

  FromAngle := 135;
  ToAngle := 405;

  noOfDivisions := 10;
  noOfSubDivisions := 3;
  FGaugeName := '';

  GlossAlpha := 200;
  if TPlatformServices.Current.SupportsPlatformService(IFMXScreenService,
    IInterface(ScreenSvc)) then
    FScale := ScreenSvc.GetScreenScale
  else
    FScale := 1;
  FForceUpdate := True;
end;

destructor TGauge.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;

procedure TGauge.DrawCallibration(const Canvas: TCanvas; const Width: single;
  const Center: TPointF);
var
  currentAngle: single;
  gap: integer;
  X, Y, x1, y1, tx, ty, radius: single;
  rulerValue, incr, totalAngle: single;
  i, j: integer;
begin
  gap := trunc(Width * 0.01);
  radius := Width / 2 - gap * 5;

  currentAngle := FromAngle * PI / 180;
  totalAngle := ToAngle - FromAngle;

  incr := totalAngle / (noOfDivisions * noOfSubDivisions) * PI / 180;
  rulerValue := MinValue;

  Canvas.stroke.Kind := TBrushKind.bkSolid;
  Canvas.stroke.Color := $FF000000;

  Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
  Canvas.Font.Size := Width / 24;

  for i := 0 to noOfDivisions do
  begin
    // Draw Thick Line
    X := (Center.X + radius * Cos(currentAngle));
    Y := (Center.Y + radius * Sin(currentAngle));
    x1 := (Center.X + (radius - Width / 20) * Cos(currentAngle));
    y1 := (Center.Y + (radius - Width / 20) * Sin(currentAngle));
    Canvas.DrawLine(PointF(X, Y), PointF(x1, y1), 1);

    // Draw Strings
    tx := (Center.X + (radius - Width / 10) * Cos(currentAngle));
    ty := (Center.Y - Width / 25 + (radius - Width / 10) * Sin(currentAngle));

    Canvas.FillText(RectF(tx, ty, tx + 1024, ty + 1024),
      format('%0.0f', [rulerValue]), false, 1, [], TTextAlign.taLeading,
      TTextAlign.taLeading);

    rulerValue := rulerValue + round((MaxValue - MinValue) / noOfDivisions);

    if i < noOfDivisions then
      for j := 0 to noOfSubDivisions - 1 do
      begin
                    // Draw thin lines
        currentAngle := currentAngle + incr;
        X := (Center.X + radius * Cos(currentAngle));
        Y := (Center.Y + radius * Sin(currentAngle));
        x1 := (Center.X + (radius - Width / 50) * Cos(currentAngle));
        y1 := (Center.Y + (radius - Width / 50) * Sin(currentAngle));
        Canvas.DrawLine(PointF(X, Y), PointF(x1, y1), 1);
      end;
  end;
end;

procedure TGauge.DrawPointer(const Canvas: TCanvas; const Width: single;
  const Center: TPointF; const Thresh: Boolean = false);
var
  radius: single;
  val: single;
  angle: single;
  pts: TPolygon;
  Value, w, len: single;

begin
  radius := Width / 2 - (Width * 0.12);
  val := MaxValue - MinValue;

  if Thresh then
  begin
    w := 6;
    Value := FThreshHold;
    len := 0.09;
  end
  else
  begin
    w := 20;
    Value := CurrentValue;
    len := 0.09;
  end;

  val := (100 * (Value - MinValue)) / val;
  val := ((ToAngle - FromAngle) * val) / 100;
  val := val + FromAngle;

  angle := val * PI / 180;

  setlength(pts, 5);
  pts[0].X := (Center.X + radius * Cos(angle));
  pts[0].Y := (Center.Y + radius * Sin(angle));

  pts[4].X := (Center.X + radius * Cos(angle - 0.02));
  pts[4].Y := (Center.Y + radius * Sin(angle - 0.02));

  angle := (val + w) * PI / 180;
  pts[1].X := (Center.X + (Width * len) * Cos(angle));
  pts[1].Y := (Center.Y + (Width * len) * Sin(angle));

  pts[2].X := Center.X;
  pts[2].Y := Center.Y;

  angle := (val - w) * PI / 180;
  pts[3].X := (Center.X + (Width * len) * Cos(angle));
  pts[3].Y := (Center.Y + (Width * len) * Sin(angle));

  if Thresh then
    Canvas.Fill.Color := $FFFF0000
  else
    Canvas.Fill.Color := $FF000000;
  Canvas.FillPolygon(pts, 1);

  if Thresh then
    exit;

  setlength(pts, 3);
  angle := val * PI / 180;
  pts[0].X := (Center.X + radius * Cos(angle));
  pts[0].Y := (Center.Y + radius * Sin(angle));

  angle := (val + w) * PI / 180;
  pts[1].X := (Center.X + (Width * len) * Cos(angle));
  pts[1].Y := (Center.Y + (Width * len) * Sin(angle));

  pts[2].X := Center.X;
  pts[2].Y := Center.Y;

  if FFlatMode then
  begin
    Canvas.Fill.Color := $FF808080;
    Canvas.FillPolygon(pts, 1);
  end
  else
  begin
    Canvas.Fill.Kind := TBrushKind.bkGradient;
    try
      Canvas.Fill.Gradient.Color := $FF808080;
      Canvas.Fill.Gradient.Color1 := $0F000000;
      Canvas.FillPolygon(pts, 1);
    finally
      Canvas.Fill.Kind := TBrushKind.bkSolid;
    end;
  end;
end;

procedure TGauge.DrawGloss(const Canvas: TCanvas; const Width: single;
  const Center: TPointF);
var
  R: TRectF;
  X, Y: single;
begin
  R := RectF(Center.X - Width / 2, Center.Y - Width / 2, Center.X + Width / 2,
    Center.Y + Width / 2);
  if not FFlatMode then
    Canvas.Fill.Kind := TBrushKind.bkGradient;
  try
    Canvas.Fill.Color := (GlossAlpha div 4 and $FF) shl 24 or $FFFFFF;
    if not FFlatMode then
    begin
      Canvas.Fill.Gradient.Color := (GlossAlpha and $FF) shl 24 or $FFFFFF;
      Canvas.Fill.Gradient.Color1 := $00FFFFFF;
    end;

    X := R.Left + (Width * 0.10);
    Y := R.Top + (Width * 0.07);
    Canvas.FillEllipse(RectF(X, Y, X + (Width * 0.80), Y + (Width * 0.7)), 1);
    Canvas.Fill.Color := ((GlossAlpha div 3) and $FF) shl 24 or
      (FBackColor and $FFFFFF);

    if not FFlatMode then
    begin
      Canvas.Fill.Gradient.Color := $00FFFFFF;
      Canvas.Fill.Gradient.Color1 := Canvas.Fill.Color;
    end;
    X := R.Left + Width * 0.25;
    Y := R.Top + Width * 0.77;
    Canvas.FillEllipse(RectF(X, Y, X + Width * 0.5, Y + Width * 0.2), 1);
  finally
    Canvas.Fill.Kind := TBrushKind.bkSolid;
  end;
end;

procedure TGauge.DrawCenterPoint(const Canvas: TCanvas; const Width: single;
  const Center: TPointF);
var
  R: TRectF;
  shift: single;
begin
  shift := Width / 5;
  R := RectF(Center.X - (shift / 2), Center.Y - (shift / 2),
    Center.X + (shift / 2), Center.Y + (shift / 2));

  if not FFlatMode then
    Canvas.Fill.Kind := TBrushKind.bkGradient;
  try
    Canvas.Fill.Color := 100 shl 24 or (FDialColor and $FFFFFF);
    if FFlatMode then
    begin
      Canvas.Fill.Gradient.Color := $FF000000;
      Canvas.Fill.Gradient.Color1 := Canvas.Fill.Color;
    end;
    Canvas.FillEllipse(R, 1);

    shift := Width / 7;
    R := RectF(Center.X - (shift / 2), Center.Y - (shift / 2),
      Center.X + (shift / 2), Center.Y + (shift / 2));

    if FFlatMode then
      Canvas.Fill.Color := $80808080
    else
    begin
      Canvas.Fill.Gradient.Color := $FF808080;
      Canvas.Fill.Gradient.Color1 := $FF000000;
    end;
    Canvas.FillEllipse(R, 1);
  finally
    Canvas.Fill.Kind := TBrushKind.bkSolid;
  end;
end;

procedure TGauge.DrawBackground(const Canvas: TCanvas;
  const RealWidth, Width, Height: single; const Center: TPointF);
var
  R: TRectF;
  Y: single;
begin
  R := RectF(Center.X - (Width / 2), Center.Y - (Width / 2),
    Center.X + (Width / 2), Center.Y + (Width / 2));
  Canvas.Fill.Color := 120 shl 24 or (FDialColor and $FFFFFF);
  Canvas.FillEllipse(R, 1);

  // Draw Rim
  Canvas.stroke.Kind := TBrushKind.bkSolid;
  Canvas.stroke.Color := $64808080;
  Canvas.DrawEllipse(R, 1);

  Canvas.stroke.Color := $FF808080;
  Canvas.DrawEllipse(R, 1);

  Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
  Canvas.Font.Size := Width / 18;

  Canvas.FillText(RectF(0, Center.Y + (Width / 4.5), RealWidth, Height), FGaugeName,
    false, 1, [], TTextAlign.taCenter, TTextAlign.taLeading);

  DrawCallibration(Canvas, Width, Center);
end;

procedure TGauge.Resize;
begin
  inherited;
  FForceUpdate := True;
end;

procedure TGauge.RenderBackground(const Width, Height: single);
var
  Center: TPointF;
begin
  if not FForceUpdate then
    exit;
  FForceUpdate := false;

  FBitmap.Resize(trunc(Width * FScale), trunc(Height * FScale));

  Center := PointF(FBitmap.Width / 2, FBitmap.Height / 2);

  FBitmap.Clear(0);
  FBitmap.Canvas.BeginScene(nil);
  DrawBackground(FBitmap.Canvas, FBitmap.Width, 0.98*FBitmap.Width, FBitmap.Height, Center);
  FBitmap.Canvas.EndScene;
end;

procedure TGauge.SetFlatMode(const Value: Boolean);
begin
  if FFlatMode <> Value then
  begin
    FFlatMode := Value;
    FForceUpdate := True;
    repaint;
  end
end;

procedure TGauge.Paint;
var
  Center: TPointF;
  w, Y: single;
begin
  RenderBackground(Width, Height);

  if Canvas.BeginScene(nil) then
    try
      Center := PointF(Width / 2, Height / 2);

      Canvas.DrawBitmap(FBitmap, RectF(0, 0, FBitmap.Width, FBitmap.Height),
        RectF(0, 0, Width, Height), 1);

      Y := Center.Y + Height / 3.5;
      w := 0.98*Width;

      Canvas.Font.Size := Width / 10;
      Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
      Canvas.FillText(RectF(0, Y, Width, Height),
        format('%0.1f', [CurrentValue]), false, 1, [], TTextAlign.taCenter,
        TTextAlign.taLeading);

      if FThreshHold >= FMinValue then
        DrawPointer(Canvas, w, Center, True);

      DrawPointer(Canvas, w, Center);

      DrawCenterPoint(Canvas, w, Center);
      DrawGloss(Canvas, w, Center);

    finally
      Canvas.EndScene;
    end;
end;

procedure TGauge.SetCurrentValue(const Value: single);
begin
  if abs(FCurrentValue - Value) >= 0.1 then
  begin
    FCurrentValue := Value;
    if (CaptureThresh) and (FThreshHold < Value) then
      FThreshHold := Value;

    repaint;
  end;
end;

procedure TGauge.ResetThreshold;
begin
  CaptureThresh := false;
  FThreshHold := FMinValue - 1;
  repaint;
end;

end.

Das läuft jetzt etwas besser, aber in Summe ist es immer noch nicht wirklich performant.

[Union]

Eventuell solltest Du lieber die generischen Routinen FillPath und DrawPath verwenden, dann muss Firemonkey Deine TPointF-Arrays nicht mehr umkopieren.