(09/2015) Я только что перепрыгнул с D6 на XE8. Имея ряд вопросов. Включая эту вещь TProgressBar. Подал это на время. Наткнулся на это (Эрик Ноулз) сегодня вечером. Фантастика. За исключением: первый сценарий, через который я пробежал, имел максимальное значение 9,770,880. И это («оригинальное» исправление Эрика Ноулза) ДЕЙСТВИТЕЛЬНО добавило ко времени, которое занял этот процесс (со всеми дополнительными актуальными обновлениями ProgressBar).
Так что я расширил его класс, чтобы уменьшить количество случаев, когда ProgressBar фактически перерисовывает себя. Но ТОЛЬКО ЕСЛИ «оригинальное» максимальное значение больше MIN_TO_REWORK_PCTS (здесь я остановился на 5000).
Если это так, ProgressBar обновляет себя только раз HUNDO (здесь я начал с почти 100, отсюда и название "HUNDO").
Я учел некоторую причуду и при значении Max:
if Abs(FOriginalMax - value) <= 1 then
pct := HUNDO
Я проверил это в сравнении с моими исходными 9,8 м Макс. И с этим автономным тестовым приложением:
:
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
1000
10000
100000
1000000
Он плавный и «точный» для всех этих значений - без какого-либо замедления.
При тестировании я смог переключить директиву компилятора 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.