A simple arc gauge control for the Delphi VCL and the Windows platform

unit Gauge;

interface

uses
  Windows, SysUtils, Types, UITypes, Classes, Graphics, Controls;

type
  TArcGauge = class(TCustomControl)
  strict private
    FBgBrush, FFgBrush: TBrush;
    FPosition: Integer;
    FInnerRadius,
    FOuterRadius: Integer;
    FShowCaption: Boolean;
    procedure SetPosition(const Value: Integer);
    procedure SetInnerRadius(const Value: Integer);
    procedure SetOuterRadius(const Value: Integer);
    procedure SetBgBrush(const Value: TBrush);
    procedure SetFgBrush(const Value: TBrush);
    procedure BrushChanged(Sender: TObject);
    procedure SetShowCaption(const Value: Boolean);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property AlignWithMargins;
    property Anchors;
    property Color;
    property Constraints;
    property Font;
    property BgBrush: TBrush read FBgBrush write SetBgBrush;
    property FgBrush: TBrush read FFgBrush write SetFgBrush;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property Position: Integer read FPosition write SetPosition default 0;
    property InnerRadius: Integer read FInnerRadius write SetInnerRadius default 50;
    property OuterRadius: Integer read FOuterRadius write SetOuterRadius default 100;
    property ShowCaption: Boolean read FShowCaption write SetShowCaption default True;
    property ShowHint;
    property Touch;
    property Visible;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnGesture;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnStartDock;
    property OnStartDrag;
  end;

procedure Register;

implementation

uses
  Math;

{ TArcGauge }

procedure TArcGauge.BrushChanged(Sender: TObject);
begin
  Invalidate;
end;

constructor TArcGauge.Create(AOwner: TComponent);
begin
  inherited;
  DoubleBuffered := True;
  FBgBrush := TBrush.Create;
  FBgBrush.OnChange := BrushChanged;
  FBgBrush.Color := clSilver;
  FFgBrush := TBrush.Create;
  FFgBrush.OnChange := BrushChanged;
  FFgBrush.Color := clNavy;
  FInnerRadius := 50;
  FOuterRadius := 100;
  FShowCaption := True;
  Caption := '0%';
end;

destructor TArcGauge.Destroy;
begin
  FFgBrush.Free;
  FBgBrush.Free;
  inherited;
end;

procedure TArcGauge.Paint;
var
  Cx: Integer;

  function InnerPoint(const APosition: Integer): TPoint;
  begin
    Result := Point(
      Round(Cx + InnerRadius*Cx*Cos((1 - APosition/100) * Pi)/100),
      Round(ClientHeight - InnerRadius*Cx*Sin((1 - APosition/100) * Pi)/100)
    );
  end;

  function OuterPoint(const APosition: Integer): TPoint;
  begin
    Result := Point(
      Round(Cx + OuterRadius*Cx*Cos((1 - APosition/100) * Pi)/100),
      Round(ClientHeight - OuterRadius*Cx*Sin((1 - APosition/100) * Pi)/100)
    );
  end;

  procedure DrawPart(AFrom, ATo: Integer; ABrush: TBrush);
  var
    InnerPointFrom,
    InnerPointTo,
    OuterPointFrom,
    OuterPointTo: TPoint;
  begin
    InnerPointFrom := InnerPoint(AFrom);
    InnerPointTo := InnerPoint(ATo);
    OuterPointFrom := OuterPoint(AFrom);
    OuterPointTo := OuterPoint(ATo);
    Canvas.Brush.Assign(ABrush);
    Canvas.Pen.Style := psClear;
    BeginPath(Canvas.Handle);
    Canvas.MoveTo(OuterPointFrom.X, OuterPointFrom.Y);
    Canvas.LineTo(InnerPointFrom.X, InnerPointFrom.Y);
    SetArcDirection(Canvas.Handle, AD_CLOCKWISE);
    Canvas.ArcTo(
      Cx - InnerRadius*Cx div 100,
      ClientHeight - InnerRadius*Cx div 100,
      Cx + InnerRadius*Cx div 100,
      ClientHeight + InnerRadius*Cx div 100,
      InnerPointFrom.X,
      InnerPointFrom.Y,
      InnerPointTo.X,
      InnerPointTo.Y
    );
    Canvas.LineTo(OuterPointTo.X, OuterPointTo.Y);
    SetArcDirection(Canvas.Handle, AD_COUNTERCLOCKWISE);
    Canvas.ArcTo(
      Cx - OuterRadius*Cx div 100,
      ClientHeight - OuterRadius*Cx div 100,
      Cx + OuterRadius*Cx div 100,
      ClientHeight + OuterRadius*Cx div 100,
      OuterPointTo.X,
      OuterPointTo.Y,
      OuterPointFrom.X,
      OuterPointFrom.Y
    );
    EndPath(Canvas.Handle);
    FillPath(Canvas.Handle);
  end;

var
  R: TRect;
  S: string;

begin
  inherited;
  Cx := ClientWidth div 2;
  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(ClientRect);
  DrawPart(Max(0, Pred(Position)), 100, FBgBrush);
  if Position > 0 then
    DrawPart(0, Position, FFgBrush);
  Canvas.Font.Assign(Font);
  R := Rect(0, ClientHeight - Canvas.TextHeight('A'), ClientWidth, ClientHeight);
  if FShowCaption then
    S := Caption;
  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.TextRect(R, S, [tfSingleLine, tfCenter]);
end;

procedure TArcGauge.SetBgBrush(const Value: TBrush);
begin
  BgBrush.Assign(Value);
end;

procedure TArcGauge.SetFgBrush(const Value: TBrush);
begin
  FgBrush.Assign(Value);
end;

procedure TArcGauge.SetInnerRadius(const Value: Integer);
begin
  if FInnerRadius <> Value then
  begin
    FInnerRadius := Value;
    Invalidate;
  end;
end;

procedure TArcGauge.SetOuterRadius(const Value: Integer);
begin
  if FOuterRadius <> Value then
  begin
    FOuterRadius := Value;
    Invalidate;
  end;
end;

procedure TArcGauge.SetPosition(const Value: Integer);
begin
  if FPosition <> Value then
  begin
    FPosition := EnsureRange(Value, 0, 100);
    Caption := FPosition.ToString + '%';
    Invalidate;
  end;
end;

procedure TArcGauge.SetShowCaption(const Value: Boolean);
begin
  if FShowCaption <> Value then
  begin
    FShowCaption := Value;
    Invalidate;
  end;
end;

procedure Register;
begin
  RegisterComponents('Rejbrand 2020', [TArcGauge]);
end;

end.