Gauge in Firemonkey - Delphi-PRAXiS (2024)

unit UGauge;

interface

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

type
TGauge = class(TControl)
protected
FFlatMode: Boolean;
FBackColor: TAlphaColor;
FDialColor: TAlphaColor;
FForeColor: TAlphaColor;

FGlossAlpha: Byte;

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

FToAngle: Single;
FFromAngle: Single;

FNoOfDivisions: integer;
FNoOfSubDivisions: integer;

FGaugeName: String;

procedure DrawDigit(const Canvas: TCanvas; const number: integer;
const position: TPointF; const dp: Boolean; const height: Single);

procedure DisplayNumber(const Canvas: TCanvas;
const X, Y, Width, height: Single; const number: Single);
procedure DrawBackground(const Canvas: TCanvas; const Width: 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 SetFlatMode(const Value: Boolean);
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 default false;
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 System.SysUtils, System.Character, FMX.Platform;

{ TGauge }
constructor TGauge.Create{$IFDEF COMPONENT}(AOwner: TComponent){$ENDIF};
begin
inherited;
{$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;
end;

destructor TGauge.Destroy;
begin
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), floattostr(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, 2);
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
if not FFlatMode then
begin
Canvas.Fill.Gradient.Color := (GlossAlpha and $FF) shl 24 or $FFFFFF;
Canvas.Fill.Gradient.Color1 := $00FFFFFF;
end
else
Canvas.Fill.Color := $20303030;

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 not 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 := $FF808080
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 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));
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), Width, Height), FGaugeName, false, 1,
[], TTextAlign.taCenter, TTextAlign.taLeading);

DrawCallibration(Canvas, Width, Center);

X := Center.X - Width / 4.8;
Y := Center.Y + Width / 3.2;

DisplayNumber(Canvas, X, Y, Width, Width / 8, CurrentValue);
end;

procedure TGauge.DisplayNumber(const Canvas: TCanvas;
const X, Y, Width, height: Single; const number: Single);
var
num: string;
shift: Single;
drawDPS: Boolean;
c: char;
i: integer;
begin
num := formatfloat('000.0', number);

shift := 0;
if (number < 0) then
shift := shift - Width / 17;

for i := low(num) to high(num) do
begin
c := num[i];
drawDPS := (i < high(num)) and (num[i + 1].IsInArray([',', '.']));

if (c <> '.') and (c <> ',') then
begin
if (c = '-') then
DrawDigit(Canvas, -1, PointF(X + shift, Y), drawDPS, height)
else
DrawDigit(Canvas, StrToInt(c), PointF(X + shift, Y), drawDPS, height);
shift := shift + 24 * Width / 250;
end
else
shift := shift + 8 * Width / 250;
end;
end;

procedure TGauge.DrawDigit(const Canvas: TCanvas; const number: integer;
const position: TPointF; const dp: Boolean; const height: Single);
var
Width: Single;
outline, fillpen: Cardinal;
Segment: TPolygon;

function GetX(const X, Width: Single): Single; inline;
begin
result := X * Width / 12;
end;

function GetY(const Y, height: Single): Single; inline;
begin
result := Y * height / 15;
end;

function IsNumberAvailable(const number: integer;
const list: array of integer): Boolean;
var
i: integer;
begin
result := false;
for i := low(list) to high(list) do
if (number = list[i]) then
begin
result := True;
exit;
end;
end;

begin
Width := 10 * height / 13;

outline := 40 shl 24 or (FDialColor and $FFFFFF);
fillpen := $FF000000;

Canvas.Fill.Color := outline;

// Segment A
setlength(Segment, 5);
Segment[0] := PointF(position.X + GetX(2.8, Width),
position.Y + GetY(1, height));
Segment[1] := PointF(position.X + GetX(10, Width),
position.Y + GetY(1, height));
Segment[2] := PointF(position.X + GetX(8.8, Width),
position.Y + GetY(2, height));
Segment[3] := PointF(position.X + GetX(3.8, Width),
position.Y + GetY(2, height));
Segment[4] := Segment[0];

if (IsNumberAvailable(number, [0, 2, 3, 5, 6, 7, 8, 9])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;
Canvas.FillPolygon(Segment, 1);

// Segment B
Segment[0] := PointF(position.X + GetX(10, Width),
position.Y + GetY(1.4, height));
Segment[1] := PointF(position.X + GetX(9.3, Width),
position.Y + GetY(6.8, height));
Segment[2] := PointF(position.X + GetX(8.4, Width),
position.Y + GetY(6.4, height));
Segment[3] := PointF(position.X + GetX(9, Width),
position.Y + GetY(2.2, height));
Segment[4] := Segment[0];
if (IsNumberAvailable(number, [0, 1, 2, 3, 4, 7, 8, 9])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;
Canvas.FillPolygon(Segment, 1);

// Segment C
Segment[0] := PointF(position.X + GetX(9.2, Width),
position.Y + GetY(7.2, height));
Segment[1] := PointF(position.X + GetX(8.7, Width),
position.Y + GetY(12.7, height));
Segment[2] := PointF(position.X + GetX(7.6, Width),
position.Y + GetY(11.9, height));
Segment[3] := PointF(position.X + GetX(8.2, Width),
position.Y + GetY(7.7, height));
Segment[4] := Segment[0];

if (IsNumberAvailable(number, [0, 1, 3, 4, 5, 6, 7, 8, 9])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;

Canvas.FillPolygon(Segment, 1);

// Segment D
Segment[0] := PointF(position.X + GetX(7.4, Width),
position.Y + GetY(12.1, height));
Segment[1] := PointF(position.X + GetX(8.4, Width),
position.Y + GetY(13, height));
Segment[2] := PointF(position.X + GetX(1.3, Width),
position.Y + GetY(13, height));
Segment[3] := PointF(position.X + GetX(2.2, Width),
position.Y + GetY(12.1, height));
Segment[4] := Segment[0];

if (IsNumberAvailable(number, [0, 2, 3, 5, 6, 8, 9])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;

Canvas.FillPolygon(Segment, 1);

// Segment E
Segment[0] := PointF(position.X + GetX(2.2, Width),
position.Y + GetY(11.8, height));
Segment[1] := PointF(position.X + GetX(1, Width),
position.Y + GetY(12.7, height));
Segment[2] := PointF(position.X + GetX(1.7, Width),
position.Y + GetY(7.2, height));
Segment[3] := PointF(position.X + GetX(2.8, Width),
position.Y + GetY(7.7, height));
Segment[4] := Segment[0];
if (IsNumberAvailable(number, [0, 2, 6, 8])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;

Canvas.FillPolygon(Segment, 1);

// Segment F
Segment[0] := PointF(position.X + GetX(3, Width),
position.Y + GetY(6.4, height));
Segment[1] := PointF(position.X + GetX(1.8, Width),
position.Y + GetY(6.8, height));
Segment[2] := PointF(position.X + GetX(2.6, Width),
position.Y + GetY(1.3, height));
Segment[3] := PointF(position.X + GetX(3.6, Width),
position.Y + GetY(2.2, height));
Segment[4] := Segment[0];
if (IsNumberAvailable(number, [0, 4, 5, 6, 7, 8, 9])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;
Canvas.FillPolygon(Segment, 1);

// Segment G
setlength(Segment, 7);
Segment[0] := PointF(position.X + GetX(2, Width),
position.Y + GetY(7, height));
Segment[1] := PointF(position.X + GetX(3.1, Width),
position.Y + GetY(6.5, height));
Segment[2] := PointF(position.X + GetX(8.3, Width),
position.Y + GetY(6.5, height));
Segment[3] := PointF(position.X + GetX(9, Width),
position.Y + GetY(7, height));
Segment[4] := PointF(position.X + GetX(8.2, Width),
position.Y + GetY(7.5, height));
Segment[5] := PointF(position.X + GetX(2.9, Width),
position.Y + GetY(7.5, height));
Segment[6] := Segment[0];
if (IsNumberAvailable(number, [2, 3, 4, 5, 6, 8, 9, -1])) then
Canvas.Fill.Color := fillpen
else
Canvas.Fill.Color := outline;

Canvas.FillPolygon(Segment, 1);

// Draw decimal point
if dp then
begin
Canvas.Fill.Color := fillpen;
Canvas.FillEllipse(RectF(position.X + GetX(10, Width), position.Y + GetY(12,
height), position.X + GetX(10, Width) + Width / 7, position.Y + GetY(12,
height) + Width / 7), 1);
end;
end;

procedure TGauge.Paint;
var
Center: TPointF;
w: Single;
begin
Center := PointF(Width / 2, height / 2);
w := 0.95 * Width;

DrawBackground(Canvas, w, Center);
if FThreshHold >= FMinValue then
DrawPointer(Canvas, w, Center, True);
DrawPointer(Canvas, w, Center);
DrawCenterPoint(Canvas, w, Center);
DrawGloss(Canvas, w, Center);
end;

procedure TGauge.SetFlatMode(const Value: Boolean);
begin
if FFlatMode <> Value then
begin
FFlatMode := Value;
// Repaint;
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.