(09/2015) 我刚从 D6 跳到 XE8。有很多问题。包括这个 TProgressBar 的东西。摆了一会儿。今晚遇到了这个（Erik Knowles）修复。极好的。除了：我遇到的第一个场景的最大值为 9,770,880。而且它（Erik Knowles 的“原始”修复）确实增加了这个过程所花费的时间（以及所有额外的 ProgressBar 实际更新）。
所以我扩展了他的类以减少 ProgressBar 实际重绘自身的次数。但仅当“原始”最大值大于 MIN_TO_REWORK_PCTS 时（我在这里确定为 5000）。
如果是这样，ProgressBar 只会自我更新 HUNDO 次（这里我从 100 开始，并且几乎确定为 100，因此得名“HUNDO”）。
我也解释了 Max 值的一些奇怪之处：
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
我用我原来的 9.8m Max 对此进行了测试。并且，使用这个独立的测试应用：
:
uses
:
ProgressBarFix;
const
PROGRESS_PTS = 500001;
type
TForm1 = class(TForm)
Label1: TLabel;
PB: TProgressBar;
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
x: integer;
begin
PB.Min := 0;
PB.Max := PROGRESS_PTS;
PB.Position := 0;
for x := 1 to PROGRESS_PTS do
begin
//let's do something
//
Label1.Caption := Format('%d of %d',[x,PROGRESS_PTS]);
Update;
PB.Position := x;
end;
PB.Position := 0;
end;
end.
PROGRESS_PTS 值为：
10
100
1,000
10,000
100,000
1,000,000
对于所有这些值来说，它都是平滑且“准确”的 - 不会真正减慢任何速度。
在测试中，我能够切换我的编译器指令 DEF_USE_MY_PROGRESS_BAR 来测试两种方式（这个 TProgressBar 替换与原始版本相比）。
请注意，您可能需要取消注释对 Application.ProcessMessages 的调用。
这是（我的“增强版”）ProgressBarFix 源代码：
unit ProgressBarFix;
interface
uses
Vcl.ComCtrls;
type
TProgressBar = class(Vcl.ComCtrls.TProgressBar)
const
HUNDO = 100;
MIN_TO_REWORK_PCTS = 5000;
private
function GetMax: integer;
procedure SetMax(value: integer);
function GetPosition: integer;
procedure SetPosition(value: integer);
published
property Max: integer read GetMax write SetMax default 100;
property Position: integer read GetPosition write SetPosition default 0;
private
FReworkingPcts: boolean;
FOriginalMax: integer;
FLastPct: integer;
end;
implementation
function TProgressBar.GetMax: integer;
begin
result := inherited Max;
end;
procedure TProgressBar.SetMax(value: integer);
begin
FOriginalMax := value;
FLastPct := 0;
FReworkingPcts := FOriginalMax > MIN_TO_REWORK_PCTS;
if FReworkingPcts then
inherited Max := HUNDO
else
inherited Max := value;
end;
function TProgressBar.GetPosition: integer;
begin
result := inherited Position;
end;
procedure TProgressBar.SetPosition(value: integer);
var
pct: integer;
begin
//Application.ProcessMessages;
if value = inherited Position then
exit;
if FReworkingPcts then
begin
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
else
pct := Trunc((value / FOriginalMax) * HUNDO);
if pct = FLastPct then
exit;
FLastPct := pct;
value := pct;
end;
if value < Max then
begin
inherited Position := Succ(value);
inherited Position := value;
end
else
begin
Max := Succ(Max);
inherited Position := Max;
inherited Position := value;
Max := Pred(Max);
end;
end;
end.