（09/2015）我刚从D6跳到XE8。遇到了一些问题，包括TProgressBar的问题。暂时搁置了一段时间。今晚偶然发现了Erik Knowles的解决方法。太棒了！但是：我运行的第一个场景的最大值为9,770,880。而且（Erik Knowles的“原始”解决方案）真的增加了这个过程所需的时间（因为所有额外的实际更新进度条）。
因此，我扩展了他的类以减少ProgressBar实际重绘的次数。但仅当“原始”最大值大于MIN_TO_REWORK_PCTS（我在这里选择了5000）时才这样做。
如果是这样，ProgressBar只会更新100次（我从这里开始并基本上定居在100，因此有“HUNDO”名称）。
我还考虑了最大值的一些怪癖：
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
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
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.
