Delphi: 圆形进度(环形进度)

Posted 2020-11-09 liujw_fc

起源：

重回DC5项目，资源下载美工提供圆形进度条，复习Delphi，为实现其颇觉有趣，遂研究其。

最终效果图如下：

 

实现：

制作TCircleProgress控件，实现方法参照系统之TGauge控件，CSDN上tp机器猫一个源码，结合GDI+绘制技术实现以消除锯齿，以Bitmap Copy技术以避免闪烁。

设计控件图标时，Delphi7自带之Image Editor在之后版本中没了，重装其取出来用。水平问题，设计亦十分粗糙。

直贴源码吧，源码及Demo可在下面下载。

{*******************************************************}
{                                                       }
{       圆形进度条，使用到GDIPlus技术                      }
{                                                       }
{              刘景威 2018                               }
{                                                       }
{*******************************************************}

unit CircleProgress;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;

const
  FORE_COLOR = clTeal;
  BACK_COLOR = clSilver;
  PEN_WIDTH  = 4;

type
  TCircleProgress = class(TGraphicControl)
  private
    { Private declarations }
    FMinValue: Longint;
    FMaxValue: Longint;
    FCurValue: Longint;
    FPenWidth: Integer;
    FShowText: Boolean;
    FForeColor: TColor;
    FBackColor: TColor;
    FFullCover: Boolean;

    procedure SetShowText(const Value: Boolean);
    procedure SetForeColor(const Value: TColor);
    procedure SetBackColor(const Value: TColor);
    procedure SetFullCover(const Value: Boolean);
    procedure SetMinValue(const Value: Longint);
    procedure SetMaxValue(const Value: Longint);
    procedure SetProgress(const Value: Longint);
    procedure SetPenWidth(const Value: Integer);
    //绘制
    procedure DrawBackground(const ACanvas: TCanvas);
    procedure DrawProgress(const ACanvas: TCanvas);
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure Resize; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    property Align;
    property Anchors;
    property BackColor: TColor read FBackColor write SetBackColor default BACK_COLOR;
    property FullCover: Boolean read FFullCover write SetFullCover default False;
    property Color;
    property Constraints;
    property Enabled;
    property ForeColor: TColor read FForeColor write SetForeColor default FORE_COLOR;
    property Font;
    property MinValue: Longint read FMinValue write SetMinValue default 0;
    property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PenWidth: Integer read FPenWidth write SetPenWidth;
    property PopupMenu;
    property Progress: Longint read FCurValue write SetProgress;
    property ShowHint;
    property ShowText: Boolean read FShowText write SetShowText default True;
    property Visible;
  end;

procedure Register;

implementation

uses
  Math, Consts, GDIPOBJ, GDIPAPI;

procedure Register;
begin
  RegisterComponents(\'Samples\', [TCircleProgress]);
end;

{ TCircleProgress }

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

  ControlStyle := ControlStyle + [csFramed, csOpaque];
  { default values }
  FMinValue := 0;
  FMaxValue := 100;
  FCurValue := 0;
  FShowText := True;
  FForeColor := FORE_COLOR;
  FBackColor := BACK_COLOR;
  FPenWidth := PEN_WIDTH;
  Width := 100;
  Height := 100;
end;

procedure TCircleProgress.DrawBackground(const ACanvas: TCanvas);
var
  g: TGPGraphics;
  p: TGPPen;
  r: TGPRectF;
  pw: Integer;
begin
  //背景
  ACanvas.Brush.Color := Self.Color;
  ACanvas.FillRect(Self.ClientRect);

  //轨道
  g := TGPGraphics.Create(ACanvas.Handle);
  pw := FPenWidth;
  if not FFullCover then
  Inc(pw, 2);
  p := TGPPen.Create(ColorRefToARGB(FBackColor), pw);
  try
    r := MakeRect(pw / 2, pw / 2, Self.Width - pw - 1, Self.Height - pw - 1);
    g.SetSmoothingMode(SmoothingModeAntiAlias);
    g.DrawEllipse(p, r);
  finally
    p.Free;
    g.Free;
  end;
end;

procedure TCircleProgress.DrawProgress(const ACanvas: TCanvas);
  procedure DrawPercent(g: TGPGraphics);
  var
    percent: Integer;
    sb: TGPSolidBrush;
    fm: TGPFontFamily;
    f: TGPFont;
    sf: TGPStringFormat;
  begin
    percent := Round(FCurValue * 100 / (FMaxValue - FMinValue));
    sb := TGPSolidBrush.Create(ColorRefToARGB(Font.Color));
    fm := TGPFontFamily.Create(Self.Font.Name);
    f := TGPFont.Create(fm, Self.Font.Size, FontStyleRegular, UnitPoint);
    sf := TGPStringFormat.Create();
    sf.SetAlignment(StringAlignmentCenter);
    sf.SetLineAlignment(StringAlignmentCenter);
    g.DrawString(Format(\'%d%%\', [percent]), -1, f, MakeRect(0.0, 0.0, Self.Width, Self.Height), sf, sb);
  end;

var
  g: TGPGraphics;
  p: TGPPen;
  pw: Integer;
  r: TGPRectF;
  angle: Single;
begin
  g := TGPGraphics.Create(ACanvas.Handle);
  p := TGPPen.Create(ColorRefToARGB(FForeColor), FPenWidth);
  try
    pw := FPenWidth;
    if not FFullCover then
      pw := pw + 2;
    r := MakeRect(pw / 2, pw / 2, Self.Width - pw - 1, Self.Height - pw - 1);

    g.SetSmoothingMode(SmoothingModeHighQuality);
    angle := (FCurValue - FMinValue) * 360 / FMaxValue;
    g.DrawArc(p, r, -90, angle);

    //画百分比
    if FShowText then
      DrawPercent(g);
  finally
    p.Free;
    g.Free;
  end;
end;

procedure TCircleProgress.Paint;
var
  bmp: TBitmap;
begin
  inherited;

  bmp := TBitmap.Create;
  try
    bmp.Height := Height;
    bmp.Width := Width;
    DrawBackground(bmp.Canvas);
    DrawProgress(bmp.Canvas);

    Canvas.CopyMode := cmSrcCopy;
    Canvas.Draw(0, 0, bmp)
  finally
    bmp.Free;
  end;
end;

procedure TCircleProgress.ReSize;
begin
  inherited;
  
  if FPenWidth > Self.Width div 2 - 1 then
  begin
    FPenWidth := Self.Width div 2 - 1;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetBackColor(const Value: TColor);
begin
  if FBackColor <> Value then
  begin
    FBackColor := Value;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetForeColor(const Value: TColor);
begin
  if FForeColor <> Value then
  begin
    FForeColor := Value;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetFullCover(const Value: Boolean);
begin
  if FFullCover <> Value then
  begin
    FFullCover := Value;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetMaxValue(const Value: Integer);
begin
  if FMaxValue <> Value then
  begin
    if Value < FMinValue then
      if not (csLoading in ComponentState) then
        raise EInvalidOperation.CreateFmt(SOutOfRange, [FMinValue + 1, MaxInt]);

    FMaxValue := Value;
    if FCurValue > Value then FCurValue := Value;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetMinValue(const Value: Integer);
begin
  if FMinValue <> Value then
  begin
    if Value > FMaxValue then
      if not (csLoading in ComponentState) then
        raise EInvalidOperation.CreateFmt(SOutOfRange, [-MaxInt, FMaxValue - 1]);

    FMinValue := Value;
    if FCurValue < Value then FCurValue := Value;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetPenWidth(const Value: Integer);
begin
  if FPenWidth <> Value then
  begin
    FPenWidth := Value;
    if FPenWidth < 1 then
      FPenWidth := 1
    else if FPenWidth > Self.Width div 2 - 1 then
      FPenWidth := Self.Width div 2 - 1;
    Invalidate;
  end;
end;

procedure TCircleProgress.SetProgress(const Value: Integer);
begin
  iF FCurValue <> Value then
  begin
    FCurValue := Value;
    if FCurValue < FMinValue then
      FCurValue := FMinValue
    else if FCurValue > FMaxValue then
      FCurValue := FMaxValue;

    Invalidate;
  end;
end;

procedure TCircleProgress.SetShowText(const Value: Boolean);
begin
  if FShowText <> Value then
  begin
    FShowText := Value;
    Invalidate;
  end;
end;

end.

 

定时器调用：

procedure TfrmMain.tmrStartTimer(Sender: TObject);
begin
  cp.Progress := cp.Progress + 1;
  if cp.Progress >= cp.MaxValue then
    tmrStart.Enabled := False;
end;

 

效果：

 

源码：

https://files.cnblogs.com/files/crwy/cp.rar