Delphi progressbar with two or more current values - delphi

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:
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?)

Answer 1

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;

Answer 2

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;

Answer 3

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.