[Delphi] TPanelのちらつきをなくす

　Delphiのバージョンにもよるが、TPanelを作成し、その上にコンポーネントを載せると激しくちらつく。バージョンが上がるにつれてちらつきが激しくなっているような気もする。
　TImageやTPaintBoxを載せるとさらにちらつきが激しくなる。TWinControlを継承しているので、DoubleBufferedが使えるが、これを指定しても全く意味がない(適用されていない?)。これらの現象を回避するには、TPanelを継承し、WM_ERASEBKGNDとWM_PAINTをフックする。

　参考URL: サンプル: "TImage 等のちらつきを効率良く抑制する"

　この方法を使えば、TPaintBoxやTImageのちらつきはなくなるが、TPanelの背景が黒くなったり、TCheckBoxやTRadioButtonが描画されなくなったりする。したがって、これをTFormに適用するのではなく、TPanelに適用する。
　pasファイルのtype節に、以下のようにTPanelを継承したクラスを作成する。

type節に追加するコード
1 2 3 4 5 6 7	type TPanel = class(StdCtrls.TPanel) private procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

　このように、TPanelを継承したTPanelを作成することで、このアプリケーション全体で使用するTPanelに変更を適用することができる。
　次に、implementation節に以下のコードを加える。下記コードは前述した参考URLとほとんど同じものである。

implementation節に追加するコード
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68	procedure TPanel.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin end; procedure TPanel.WMPaint(var Message: TWMPaint); var PS: TPaintStruct; w, h: Integer; DC: HDC; bmp, bmpOld: HBITMAP; i, Count, SaveDCIndex: Integer; begin if Message.DC <> 0 then inherited else begin BeginPaint(Handle, PS); try w := PS.rcPaint.Right - PS.rcPaint.Left; h := PS.rcPaint.Bottom - PS.rcPaint.Top; DC := GetDC(HWND(0)); bmp := CreateCompatibleBitmap(DC, w, h); ReleaseDC(HWND(0), DC); try Message.DC := CreateCompatibleDC(HDC(0)); with PS do try bmpOld := SelectObject(Message.DC, bmp); with rcPaint do SetWindowOrgEx(Message.DC, Left, Top, nil); FillRect(Message.DC, rcPaint, Brush.Handle); Count := ControlCount; for i := 0 to Count - 1 do begin if Controls[i] is TWinControl then break; with Controls[i] do begin if Visible and RectVisible(hdc, BoundsRect) then begin SaveDCIndex := SaveDC(Message.DC); OffsetWindowOrgEx(Message.DC, -Left, -Top, nil); IntersectClipRect(Message.DC, 0, 0, Width, Height); Perform(WM_PAINT, Message.DC, 0); RestoreDC(Message.DC, SaveDCIndex); end; end; end; BitBlt(hdc, rcPaint.Left, rcPaint.Top, w, h, Message.DC, rcPaint.Left, rcPaint.Top, SRCCOPY); SelectObject(Message.DC, bmpOld); finally DeleteDC(Message.DC); Message.DC := 0; end; finally DeleteObject(bmp); end; finally EndPaint(Handle, PS); end; end; end;

implementation節に追加するコード

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

procedure TPanel.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin

end;

procedure TPanel.WMPaint(var Message: TWMPaint);
var
  PS: TPaintStruct;
  w, h: Integer;
  DC: HDC;
  bmp, bmpOld: HBITMAP;
  i, Count, SaveDCIndex: Integer;
begin
  if Message.DC <> 0 then
    inherited
  else
  begin
    BeginPaint(Handle, PS);
    try
      w := PS.rcPaint.Right - PS.rcPaint.Left;
      h := PS.rcPaint.Bottom - PS.rcPaint.Top;
      DC := GetDC(HWND(0));
      bmp := CreateCompatibleBitmap(DC, w, h);
      ReleaseDC(HWND(0), DC);
      try
        Message.DC := CreateCompatibleDC(HDC(0));
        with PS do
        try
          bmpOld := SelectObject(Message.DC, bmp);

          with rcPaint do
            SetWindowOrgEx(Message.DC, Left, Top, nil);
          FillRect(Message.DC, rcPaint, Brush.Handle);

          Count := ControlCount;
          for i := 0 to Count - 1 do
          begin
            if Controls[i] is TWinControl then
              break;
            with Controls[i] do
            begin
              if Visible and RectVisible(hdc, BoundsRect) then
              begin
                SaveDCIndex := SaveDC(Message.DC);
                OffsetWindowOrgEx(Message.DC, -Left, -Top, nil);
                IntersectClipRect(Message.DC, 0, 0, Width, Height);
                Perform(WM_PAINT, Message.DC, 0);
                RestoreDC(Message.DC, SaveDCIndex);
              end;
            end;
          end;

          BitBlt(hdc, rcPaint.Left, rcPaint.Top, w, h,
              Message.DC, rcPaint.Left, rcPaint.Top, SRCCOPY);

          SelectObject(Message.DC, bmpOld);
        finally
          DeleteDC(Message.DC);
          Message.DC := 0;
        end;
      finally
        DeleteObject(bmp);
      end;
    finally
      EndPaint(Handle, PS);
    end;
  end;
end;

　コントロールは再描画の際、一度領域をクリアしてから再描画する。したがって、この再描画を無効化することでちらつきを抑える。
　しかし、このままではTCheckBoxやTRadioButtonなどの背景が正しく描画されないため、これらのコントロールについては背景をクリアしてやらなければならない。したがって、WMEraseBkgndに以下のようなコードを追加する。

TPanel.WMEraseBkgndに追加するコード
1 2 3 4 5 6 7 8 9 10 11 12 13	procedure TPanel.WMEraseBkgnd(var Message: TWMEraseBkgnd); var i, Count: Integer; begin Count := ControlCount - 1; for i := 0 to Count do begin if Controls[i] is TWinControl then if Controls[i].Visible then FillRect(Message.DC, TWinControl(Controls[i]).BoundsRect, TWinControl(Controls[i]).Brush.Handle); end; end;

TPanel.WMEraseBkgndに追加するコード

1
2
3
4
5
6
7
8
9
10
11
12
13

procedure TPanel.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
  i, Count: Integer;
begin
  Count := ControlCount - 1;
  for i := 0 to Count do
  begin
    if Controls[i] is TWinControl then
      if Controls[i].Visible then
        FillRect(Message.DC, TWinControl(Controls[i]).BoundsRect,
          TWinControl(Controls[i]).Brush.Handle);
  end;
end;

　TWinControlを継承したコンポーネントの場合は、背景をそのまま描画する。
FillRectの部分をinheritedにしたくなるが、そうするとTPanelのちらつきが発生してしまう(TPanelがなにか独自の描画を行っている?)。

トップへ

ホーム > サブコンテンツ > 技術系情報 > TPanelのちらつきをなくす[Delphi]