Delphi进度条具有两个或多个当前值

Question

我想在我的软件中制作一种多颜色条。一种进度条，但有两个当前值。

这就是我需要它的原因。 我有一些“预算部分”，每个部分都有自己的限制（100美元，1000美元等）。 我还有一个编辑表单，用于添加新账单（并将账单链接到预算部分）。 在这个编辑器中，我希望直观地表示预算部分的填充情况，以及当前账单价格对该预算部分的影响程度。

例如，整个条形图为100美元。 绿色部分表示已保存账单的价格总和，例如60美元。 黄色部分表示当前未保存的账单价格，例如5美元。

像这样： 当然，值应该动态设置。

你能推荐给我任何绘制这个组件的工具吗（也许是一些高级进度条，可以显示多个当前值）？

- Vasiliy Volkov

---

这是世界上最容易绘制的组件。您只需要一个“Paint”方法，它会绘制一个边界矩形，然后用两种颜色填充内部。它不是进度条，而是一个仪表。我不确定是否要寻找第三方组件。我会自己绘制它。 - David Heffernan

您可以使用TGauge组件源代码（在Delphi安装文件夹中的..\source\Samples\Delphi\Gauges.pas）作为编写进度条组件的起点。 - kludg

Answer 1

正如David所建议的那样，自己来绘制吧。几乎同样麻烦。将 TImage 拖放到想要放置仪表盘的位置，然后使用以下代码：

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;

例如，这段代码对我的3个TImage所做的操作如下（我的图片有意地呈现出您所看到的形状）：

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;

- Cosmin Prund

---

我会使用 TPaintBox，或者创建一个派生自 TGraphicControl 的自定义组件。这两种方法都比 TImage 使用更少的系统资源。您仍然可以使用上述逻辑，只需在 TPaintBox.OnPaint 事件或重写的 TGraphicControl.Paint() 方法中使用组件自己的 Canvas 属性即可。 - Remy Lebeau

@Remy 我同意你的观点，但我相信Cosmin选择TImage是为了更容易地被采用。 - NGLN

@NGLN，对于这个目的，TPaintBox比TImage更容易使用。不需要临时位图。 - David Heffernan

@David Nor使用TImage，它有一个画布可以绘制。我的意思是不需要存储值和颜色。 - NGLN

@RemyLebeau,@NGLN：任何不存储位图的东西都需要存储仪表的当前设置（颜色、位置）。使用TImage不需要这样做：您可以在窗体上放置一个TImage，然后使用任何您拥有的值调用该单个过程。无需辅助存储，无需私有字段声明。运行时效率不如其他方法（因为它存储了整个位图，而只有7个字段可能会这样做）-但并不是问题。我特别为OP的问题编写了这篇文章，但下次我想编写一个小控件时，我可能会应用这个方法到我的代码中。 - Cosmin Prund

Answer 2

自己编写组件很有趣! 但是对于初学者或没有相关经验的人来说，编写自己的组件可能看起来令人望而却步。

下一个选项是自行绘制，因此预期的组件应始终为TPaintBox控件。实现OnPaint事件处理程序，并在需要时重新绘制自身。以下是如何将这样的绘图框转换为双刻度计组件的示例实现:

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;

看起来这需要相当大的努力，特别是当在单个表单上需要更多这样的双重测量时。因此，我喜欢 Cosmin Prund的回答，因为他使用了TImage组件，这些组件能够“记忆”需要重新绘制的内容。作为一个额外的奖励，这里提供他代码的另一种替代版本（输入无效时行为略有不同）：

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;

- NGLN

Answer 3

我也在寻找这个，因为我不想花费任何钱，所以我会遵循提出的解决方案，不过如果有人需要高级组件，我发现了一个价格不太贵且外观相当不错的，这是链接，如果对其他人有用的话：

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

感谢大家。

- danzig