(2015 年 9 月) 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 の置換と元の 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.