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

Question

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

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

例如，整个酒吧是 100 美元。绿色部分表示已保存账单的价格总和，例如 60 美元。黄色部分表示当前账单价格，尚未保存，例如5$。

像这样:

当然，值应该动态设置。

您能给我推荐任何用于绘制此图的组件吗(也许是一些高级进度条，可以显示多个当前值？)

Answer 1

正如大卫建议的那样，自己画吧。几乎同样多的麻烦。将 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;