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

The control is based on the Windows GDI, an API first developed in the 1980s. Its age becomes somewhat apparent when you consider the lack of antialiasing, for instance.

An animated screenshot of the gauge control

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.