Ошибка индикатора выполнения темы Windows 7 Aero?

Отключите параметр визуального эффекта «Анимировать элементы управления и элементы внутри окон» в «Параметры производительности». Тогда полосы прогресса больше не будут анимированы.

Я видел похожие проблемы с индикаторами выполнения в Vista и Windows 7.

Ключевой проблемой в моем случае была блокировка потока пользовательского интерфейса. (Как и в вашем примере).

Windows не любит приложения, которые не отвечают на новые сообщения в очереди сообщений. Если вы потратите слишком много времени на одно сообщение, Windows отметит ваше приложение как «не отвечающее». В Vista / Win7 Windows также решает прекратить обновление окна вашего приложения.

В качестве обходного пути вы можете передать фактическую работу фоновому исполнителю или время от времени вызывать Application.DoEvents(). Вам нужно убедиться, что окно индикатора выполнения является модальным, иначе DoEvents () может разрешить запуск новых команд на полпути в фоновой обработке.

Если вам кажется, что это непонятно, более правильный способ - выполнить фоновую работу в BackgroundWorker потоке. Он поддерживает отправку событий в поток пользовательского интерфейса для обновления индикатора выполнения.

(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 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.