Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- unit UMyCircleProgress;
- 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);
- //draw
- 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('My Componentes', [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
- //background
- ACanvas.Brush.Color := Self.Color;
- ACanvas.FillRect(Self.ClientRect);
- //track
- 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);
- //Paint percentage
- 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.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement