Delphi progressbar with two or more current values

Question

I want to make a kind of multi-color bar in my software. A kind of progressbar, but with two current values.

That's why I need it. I have some "budget parts", and each one of them has its own limit (100$, 1000$ etc.) I also have an editing form for adding new bills (and linking bills to budget parts). In this editor I want to visually represent how full is a budget part, and how much price of current bill affects this budget part.

For example, the whole bar is 100$. Green part means sum of prices across saved bills, for example 60$. Yellow part means price of the current bill, which is not saved yet, for example 5$.

Like this: multi-part progressbar

Of course, values should be set dynamically.

Can you recommend me any components for drawing this (maybe some advanced progressbar, that can display more than one current value?)

That's about the easiest component in the world to draw. You just need a `Paint` method that paints a bounding rectangle and then fills the interior with your two colours. It's no a progress bar really, it's a gauge. I'm not sure I'd look for a third party component. I'd just paint it myself. — David Heffernan, Jan 14 '13 at 17:54
You can use `TGauge` component sources (from `..\source\Samples\Delphi\Gauges.pas` in Delphi installation folder) as a starting point to write your progressbar component. — kludg, Jan 14 '13 at 18:35

Cosmin Prund · Accepted Answer · 2013-01-14T19:20:05.087

As David suggests, just paint it yourself. Just about the same amount of trouble. Drop a TImage where you want your gauge and use something like this:

procedure PaintTwoColorGauge(const BackgroundColor, BorderColor, FirstGaugeColor, SecondGaugeColor: TColor; FirstGaugeValue, SecondGaugeValue, TotalValue: Integer; const Img: TImage);
var B: TBitmap;
    ImgWidth, G1Width, G2Width: Integer;
begin
  B := TBitmap.Create;
  try
    B.Width := Img.Width;
    B.Height := Img.Height;
    B.Canvas.Brush.Color := BackgroundColor;
    B.Canvas.Brush.Style := bsSolid;
    B.Canvas.Pen.Style := psClear;
    B.Canvas.Pen.Width := 1;
    B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));

    if TotalValue <> 0 then
    begin
      ImgWidth := B.Width - 2; // Don't account the width of the borders.
      G1Width := (FirstGaugeValue * ImgWidth) div TotalValue;
      G2Width := (SecondGaugeValue * ImgWidth) div TotalValue;
      if G1Width > ImgWidth then G1Width := ImgWidth; // Just in case
      if G2Width > ImgWidth then G2Width := ImgWidth;

      if G2Width > G1Width then
        begin
          B.Canvas.Brush.Color := SecondGaugeColor;
          B.Canvas.FillRect(Rect(0, 0, G2Width, B.Height));

          B.Canvas.Brush.Color := FirstGaugeColor;
          B.Canvas.FillRect(Rect(0, 0, G1Width, B.Height));
        end
      else
        begin
          B.Canvas.Brush.Color := FirstGaugeColor;
          B.Canvas.FillRect(Rect(0, 0, G1Width, B.Height));

          B.Canvas.Brush.Color := SecondGaugeColor;
          B.Canvas.FillRect(Rect(0, 0, G2Width, B.Height));
        end;

    end;

    B.Canvas.Pen.Color := BorderColor;
    B.Canvas.Pen.Style := psSolid;
    B.Canvas.Brush.Style := bsClear;
    B.Canvas.Rectangle(0, 0, B.Width, B.Height);

    Img.Picture.Assign(B);

  finally B.Free;
  end;
end;

For example, here's what this code does to my 3 TImages (my images are intentionally shpaed as you see them):

procedure TForm1.FormCreate(Sender: TObject);
begin
  PaintTwoColorGauge(clWhite, clBlack, clGreen, clYellow, 50, 55, 100, Image1);
  PaintTwoColorGauge(clWhite, clBlack, clGreen, clYellow, 50, 60, 100, Image2);
  PaintTwoColorGauge(clWhite, clBlack, clGreen, clYellow, 20, 60, 100, Image3);
end;

enter image description here

I would use a `TPaintBox` instead, or create a custom component derived from `TGraphicControl`. Either one will use fewer system resources than a `TImage`. You can still use the above logic, just use the component's own `Canvas` property instead, either in the `TPaintBox.OnPaint` event or the overridden `TGraphicControl.Paint()` method. — Remy Lebeau, Jan 14 '13 at 19:55
@Remy I'm with you, but I'm sure Cosmin choose for `TImage` for ease of adoptation. — NGLN, Jan 14 '13 at 20:05
@NGLN TPaintBox is easier for this purpose than `TImage`. No temp bitmap needed. — David Heffernan, Jan 14 '13 at 20:09
@David Nor with `TImage`, which has a canvas you can draw to. I meant no need for storage of values and colors. — NGLN, Jan 14 '13 at 20:15
Thanks to all of you! I think I'll adapt Cosmin's code for TPaintBox, as David and Remy suggested. Thanks again! — Vasiliy Volkov, Jan 14 '13 at 20:29
@NGLN: `TImage` does not have its own `TCanvas` object. Yes, it has a `Canvas` property, but internally it merely forces the `TImage` to create a `TBitmap` inside of its `Picture` property and then delegates to it for drawing. `TPaintBox` and `TGraphicControl` have true `TCanvas` objects that draw directly to OS-provided onscreen `HDC`s instead. — Remy Lebeau, Jan 14 '13 at 20:32
@RemyLebeau,@NGLN: Anything that doesn't store the bitmap needs storage for the current setup of the gauge (colors,positions). Using `TImage` needs no such thing: you can drop a `TImage` on a form then call that single procedure with whatever values you've got. No need for secondary storage, no need for private field declarations. Not as efficient at runtime (because it stores a whole bitmap where only 7 fields might do) - but not exactly a problem. I specifically wrote this for the OP's question, but I'll probably apply this for my own code next time I feel the urge to write a tiny control. — Cosmin Prund, Jan 15 '13 at 07:02

score 2 · Answer 2 · edited May 23 '17 at 10:24

Write your own, it's fun! But while not really thát difficult, writing an own component could look like a daunting task. Especially for novice uses or without experience doing so.

Next in line of options is to draw it yourself, and the therefore intended component should "always" be the TPaintBox control. Implement the OnPaint event handler and it redraws itself when needed. Here an example implementation of how to transform such a paint box into a double gauge component:

type
  TDoubleGauge = record
    BackgroundColor: TColor;
    BorderColor: TColor;
    Color1: TColor;
    Color2: TColor;
    Value1: Integer;
    Value2: Integer;
    MaxValue: Integer;
  end;

  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    FDoubleGauge: TDoubleGauge;
  end;

...

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
  Box: TPaintBox absolute Sender;
  MaxWidth: Integer;
  Width1: Integer;
  Width2: Integer;
begin
  with FDoubleGauge do
  begin
    Box.Canvas.Brush.Color := BackgroundColor;
    Box.Canvas.Pen.Color := BorderColor;
    Box.Canvas.Rectangle(0, 0, Box.Width, Box.Height);
    if MaxValue <> 0 then
    begin
      MaxWidth := Box.Width - 2;
      Width1 := (MaxWidth * Value1) div MaxValue;
      Width2 := (MaxWidth * Value2) div MaxValue;
      Box.Canvas.Brush.Color := Color2;
      if Abs(Value2) < Abs(MaxValue) then
        Box.Canvas.FillRect(Rect(1, 1, Width2, Box.Height - 1));
      Box.Canvas.Brush.Color := Color1;
      if Abs(Value1) < Abs(Value2) then
        Box.Canvas.FillRect(Rect(1, 1, Width1, Box.Height - 1));
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FDoubleGauge.BackgroundColor := clWhite;
  FDoubleGauge.BorderColor := clBlack;
  FDoubleGauge.Color1 := clGreen;
  FDoubleGauge.Color2 := clYellow;
  FDoubleGauge.Value1 := 50;
  FDoubleGauge.Value2 := 60;
  FDoubleGauge.MaxValue := 100;
  PaintBox1.Invalidate;
end;

Well, that looks like quite an effort. Especially when there are more of such doudble gauges needed on a single form. Therefore I like Cosmin Prund's answer, because he uses TImage components which are capable of "memorizing" what has to be redrawn when needed. Just as a bonus, here an alternative version of his code (with slightly different behaviour on invalid input):

procedure DrawDoubleGauge(BackgroundColor, BorderColor, Color1, Color2: TColor;
  Value1, Value2, MaxValue: Integer; Img: TImage);
var
  Width: Integer;
  Width1: Integer;
  Width2: Integer;
begin
  Img.Canvas.Brush.Color := BackgroundColor;
  Img.Canvas.Pen.Color := BorderColor;
  Img.Canvas.Rectangle(0, 0, Img.Width, Img.Height);
  if MaxValue <> 0 then
  begin
    Width := Img.Width - 2;
    Width1 := (Width * Value1) div MaxValue;
    Width2 := (Width * Value2) div MaxValue;
    Img.Canvas.Brush.Color := Color2;
    if Abs(Value2) < Abs(MaxValue) then
      Img.Canvas.FillRect(Rect(1, 1, Width2, Img.Height - 1));
    Img.Canvas.Brush.Color := Color1;
    if Abs(Value1) < Abs(Value2) then
      Img.Canvas.FillRect(Rect(1, 1, Width1, Img.Height - 1));
  end;
end;

score 1 · Answer 3 · answered Oct 03 '13 at 17:03

I was also looking for this exactly, as I don't want to spend any money on this I will follow the proposed solution, nevertheless if anyone would like an advanced component I found one that's not too expensive and look pretty decent in my opinion, here's the link in case it could be useful for someone else:

http://www.tmssoftware.com/site/advprogr.asp?s=

Thank's to all.

Delphi progressbar with two or more current values

3 Answers3

Linked