フォーラム


ゲスト  

ようこそ ゲスト さん。このフォーラムに投稿するには 登録が必要です。
ページ: [1]
トピック: Vista 以降で TProgressBar が遅い
DEKO
管理者
投稿数: 2690
Vista 以降で TProgressBar が遅い
on: 2013/11/16 09:08 Sat

Vista 以降ではプログレスバーの描画が遅いです。Position の値を変更すると SendMessage() で PBM_SETPOS しますので、SendMessage() が帰ってくるまで待たされます。以下のコードを試してみてください。

var
  I : Integer;
  st: cardinal;
begin
  ProgressBar1.Position := 0;
  st := GetTickCount;

  for I := 1 to 100000 do
    begin
      ProgressBar1.Position := Trunc(I / 100000 * 100);
    end;

  Caption := IntToStr(GetTickCount - st);
end;

　
以下のようにして必要最低限の描画にすれば速くなります。

var
  I : Integer;
  st: cardinal;
  CurrentPosition, OldPosition: Integer;
begin
  ProgressBar1.Position := 0;
  CurrentPosition       := ProgressBar1.Position;
  OldPosition           := ProgressBar1.Position;
  st := GetTickCount;

  for I := 1 to 100000 do
    begin
      CurrentPosition := Trunc(I / 100000 * 100);
      if OldPosition <> CurrentPosition then
        ProgressBar1.Position := CurrentPosition;
      OldPosition := CurrentPosition;
    end;

  Caption := IntToStr(GetTickCount - st);
end;

　
ですが、これを毎回毎回記述するのは面倒ですので、ComCtrls.pas を書き換えてしまいましょう。ComCtrls.pas をプロジェクトフォルダへコピーしてから書き換えます。まず、定義部に FOPosition というフィールドを定義します。

  TProgressBar = class(TWinControl)
  private
    F32BitMode: Boolean;
    FMin: Integer;
    FMax: Integer;
    FPosition: Integer;
    FStep: Integer;
    FOrientation: TProgressBarOrientation;
    FSmooth: Boolean;
    FOPosition: Integer; // Add
    function GetMin: Integer;
    function GetMax: Integer;
    function GetPosition: Integer;
    procedure SetParams(AMin, AMax: Integer);
    procedure SetMin(Value: Integer);

  ...

　
次に、コンストラクタでフィールドの値を初期化します…ここは省略してもかまいません。

constructor TProgressBar.Create(AOwner: TComponent);
begin
  F32BitMode := InitCommonControl(ICC_PROGRESS_CLASS);
  inherited Create(AOwner);
  Width := 150;
  Height := GetSystemMetrics(SM_CYVSCROLL);
  FMin := 0;
  FMax := 100;
  FStep := 10;
  FOrientation := pbHorizontal;
  FOPosition := 0; // Add
end;

　
そして SetPosition() を書き換えます

procedure TProgressBar.SetPosition(Value: Integer);
begin
  if FOPosition = Value then  // Add
    Exit;                     // Add
  if not F32BitMode and ((Value < 0) or (Value > Limit16)) then
    ProgressLimitError;
  if HandleAllocated then
    SendMessage(Handle, PBM_SETPOS, Value, 0)
  else
    FPosition := Value;
  FOPosition := Value;        // Add
end;

　
これで完了です。一番最初に挙げたコードで速度をテストしてみてください。なお、この件は Delphi 固有の問題ではありません。プログレスバーは Windows のコモンコントロールですからね。上記修正は Delphi 2007 のソースコードをベースとしていますので、他のバージョンの Delphi では記述が若干異なるかもしれません…まぁ、やる事は同じなので難しい修正ではないでしょう。

…XE 以降の Starter Edition ではこの方法は使えませんので、 TProgressBar クラスを継承するなりしてどうにかするしかないように思えます。

See Also:
[ランタイムテーマ有効時のプログレスバー処理が遅い (Delphi Q&A)]
http://hpcgi1.nifty.com/MADIA/DelphiBBS/wwwlng.cgi?print+201311/13110016.txt
DEKO
管理者
投稿数: 2690
継承するなりしてどうにかする
on: 2013/11/16 09:50 Sat

以下のユニットを用意します。

[uProgressbarFix.pas]
unit uProgressbarFix;

interface

uses
  Classes, Windows, StdCtrls, ComCtrls, CommCtrl;

type
  TProgressBar = class(ComCtrls.TProgressBar)
  private
    FPosition: Integer;
    procedure SetPosition(const Value: Integer);
    function GetPosition: Integer;
  public
    constructor Create(AOwner: TComponent); override;
    property Position: Integer read GetPosition write SetPosition default 0;
  end;

implementation

{ TProgressBar }

constructor TProgressBar.Create(AOwner: TComponent);
begin
  inherited;
  FPosition := 0;
end;

function TProgressBar.GetPosition: Integer;
begin
  if HandleAllocated then
    Result := SendMessage(Handle, PBM_GETPOS, 0, 0)
  else
    Result := FPosition;
end;

procedure TProgressBar.SetPosition(const Value: Integer);
begin
  if FPosition <> Value then
    begin
      FPosition := Value;
      if HandleAllocated then
        SendMessage(Handle, PBM_SETPOS, Value, 0);
    end;
end;

end.

　
使い方は ProgressBar を使っているユニットの uses に uProgressbarFix を追加するだけです (ComCtrls よりも後に uses してください)。既存のコードを修正する必要はありません。
ページ: [1]
WP Forum Server by ForumPress | LucidCrew
バージョン: 1.7.5 ; ページロード: 0.029 sec.