具有兩個或更多當前值的Delphi進度條

Question

我想在我的軟件中製作一種多色條。一種進度條，但有兩個當前值。

這就是爲什麼我需要它。 我有一些「預算部分」，他們每個人都有自己的限制（100 $，1000 $等）。 我也有一個編輯表格，用於添加新賬單（以及將賬單鏈接到預算部分）。 在這個編輯器中，我想直觀地表示預算部分是多麼充分，以及當前賬單的多少價格影響這個預算部分。

例如，整個酒吧是100美元。 綠色部分是指所有已保存賬單的價格總和，例如60美元。 黃色部分表示當前賬單的價格，尚未保存，例如5美元。

像這樣：

當然，值應該動態地設置。

你能推薦我任何部件繪製這個（也許一些先進的進度，可以顯示一個以上的電流值？）

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個TImages（當你看到他們我的圖片故意shpaed）：

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

寫你自己的，很有趣！但是，雖然實際上並不困難，但編寫自己的組件看起來可能是一項艱鉅的任務。特別是新手使用或沒有經驗的做法。

接下來的選項是自己繪製它，因此預期的組件應始終爲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's answer，因爲他使用了能夠「記憶」必要時需要重繪的內容的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; 

Answer 3

我也在找這完全是，因爲我不想花任何錢，這我將按照提出的解決方案，但如果有人想一個高級組件，我發現一個，這不是太昂貴，並期待在我看來相當不錯，這裏的情況下，鏈接也可能是爲別人有用：

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

感謝所有人。