web-dev-qa-db-ja.com

Delphiでちらつきのないセグメント化されたグラフィックスの更新を行うための最良の方法は？

私はこれを捨てて、ただ尋ねることができると思いました：グラフィック効果の点で完璧なDelphiコントロールを見たことがあります。意味：ちらつきがなく、セクション化された更新（ダーティとしてマークされたコントロールのセクションのみを再描画）およびスムーズなスクロール。

私は何年にもわたって多くのグラフィックコントロールをコーディングしてきたので、ダブルバッファリング、dibs、bitblts、およびすべての「一般的な」ものについて知っています（可能な場合は常にdibsを使用してすべてを描画しますが、オーバーヘッドがあります）。また、InvalidateRectについて知っており、更新が必要な実際のrectについてTCanvas.ClipRectをチェックしています。これらすべての典型的なソリューションにもかかわらず、DeveloperExpressやRazedComponentsなどと同じ品質のコンポーネントを作成するのは非常に難しいと思います。グラフィックが滑らかな場合は、スクロールバー（ネイティブ）のちらつきを賭けることができます。スクロールバーとフレームが滑らかな場合は、スクロール中に背景のちらつきを誓うことができます。

これを処理するためのコードの標準設定はありますか？コントロールの非クライアント領域を含む、コントロール全体のスムーズな再描画を保証する一種のベストプラクティス？

たとえば、これはセグメント化された更新の高さを取得する「ベアボーン」コントロールです（必要なものだけを再描画します）。フォーム上に作成する場合は、ウィンドウをその上に移動して、パーツが色に置き換わるのを確認してください（ペイント方法を参照）。

クライアント以外の領域の再描画をちらつきなく処理できる同様の基本クラスを持っている人はいますか？

type

TMyControl = Class(TCustomControl)
private
  (* TWinControl: Erase background prior to client-area Paint *)
  procedure WMEraseBkgnd(var Message: TWmEraseBkgnd);message WM_ERASEBKGND;
Protected
  (* TCustomControl: Overrides client-area Paint mechanism *)
  Procedure Paint;Override;

  (* TWinControl: Adjust Win32 parameters for CreateWindow *)
  procedure CreateParams(var Params: TCreateParams);override;
public
  Constructor Create(AOwner:TComponent);override;
End;


{ TMyControl }

Constructor TMyControl.Create(AOwner:TComponent);
Begin
  inherited Create(Aowner);
  ControlStyle:=ControlStyle - [csOpaque];
end;

procedure TMyControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  (* When a window has this style set, any areas that its
     child windows occupy are excluded from the update region. *)
  params.ExStyle:=params.ExStyle + WS_CLIPCHILDREN;

  (* Exclude VREDRAW & HREDRAW *)
  with Params.WindowClass do
  Begin
    (* When a window class has either of these two styles set,
       the window contents will be completely redrawn every time it is
       resized either vertically or horizontally (or both) *)
    style:=style - CS_VREDRAW;
    style:=style - CS_HREDRAW;
  end;
end;

procedure TMyControl.Paint;

  (* Inline proc: check if a rectangle is "empty" *)
  function isEmptyRect(const aRect:TRect):Boolean;
  Begin
    result:=(arect.Right=aRect.Left) and (aRect.Bottom=aRect.Top);
  end;

  (* Inline proc: Compare two rectangles *)
  function isSameRect(const aFirstRect:TRect;const aSecondRect:TRect):Boolean;
  Begin
    result:=sysutils.CompareMem(@aFirstRect,@aSecondRect,SizeOf(TRect))
  end;

  (* Inline proc: This fills the background completely *)
  Procedure FullRepaint;
  var
    mRect:TRect;
  Begin
    mRect:=getClientRect;
    AdjustClientRect(mRect);
    Canvas.Brush.Color:=clWhite;
    Canvas.Brush.Style:=bsSolid;
    Canvas.FillRect(mRect);
  end;

begin
  (* A full redraw is only issed if:
      1. the cliprect is empty
      2. the cliprect = clientrect *)
  if isEmptyRect(Canvas.ClipRect)
  or isSameRect(Canvas.ClipRect,Clientrect) then
  FullRepaint else
  Begin
    (* Randomize a color *)
    Randomize;
    Canvas.Brush.Color:=RGB(random(255),random(255),random(255));

    (* fill "dirty rectangle" *)
    Canvas.Brush.Style:=bsSolid;
    Canvas.FillRect(canvas.ClipRect);
  end;
end;

procedure TMyControl.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
  message.Result:=-1;
end;

更新

私はただ、トリックがしたのは次の組み合わせであったことを付け加えたかっただけです。

  1. 非クライアントエリアを描画するときにExcludeClipRect（）を使用するため、クライアントエリアのグラフィックと重複しないようにします

  2. 測定にbordersizeを使用するだけでなく、WMNCCalcSizeメッセージをキャッチします。また、エッジサイズの高さも考慮する必要がありました。

    XEdge := GetSystemMetrics(SM_CXEDGE);
YEdge := GetSystemMetrics(SM_CYEDGE);

  3. スクロールバーが移動したりサイズ変更されたりした場合は、次のフラグを使用してRedrawWindow（）を呼び出します。

    mRect:=ClientRect;
mFlags:=rdw_Invalidate
  or RDW_NOERASE
  or RDW_FRAME
  or RDW_INTERNALPAINT
  or RDW_NOCHILDREN;
RedrawWindow(windowhandle,@mRect,0,mFlags);

  4. Paint（）メソッドの実行中に背景を更新するときは、次のように可能な子オブジェクトを描画しないでください（上記のRDW_NOCHILDRENを参照）。

    for x := 1 to ControlCount do
begin
  mCtrl:=Controls[x-1];
  if mCtrl.Visible then
  Begin
    mRect:=mCtrl.BoundsRect;
    ExcludeClipRect(Canvas.Handle,
    mRect.Left,mRect.Top,
    mRect.Right,mRect.Bottom);
  end;
end;

助けてくれてありがとう！

delphiwinapigraphics
45
Jon Lennart Aasenden

たとえば、これはセグメント化された更新の高さを取得する「ベアボーン」コントロールです（必要なものだけを再描画します）。フォーム上に作成する場合は、ウィンドウをその上に移動して、パーツが色に置き換わるのを確認してください（ペイント方法を参照）。

クライアント以外の領域の再描画をちらつきなく処理できる同様の基本クラスを持っている人はいますか？

ええと、あなたのTMyControlには（まだ）非クライアントエリアがありません。そこで、BorderWidth := 10;を追加しましたが、現在は追加されています。 ;）

一般に、デフォルトのWindowsウィンドウの非クライアント領域は、スクロールバーやタイトルなどを含め、ちらつきなく自動的にペイントされます（少なくとも、他の方法では目撃していません）。

独自の境界線をペイントする場合は、WM_NCPAINTを処理する必要があります。このコードを参照してください：

unit Unit2;

interface

uses
  Classes, Controls, Messages, Windows, SysUtils, Graphics;

type
  TMyControl = class(TCustomControl)
  private
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
  protected
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner:TComponent);override;
  end;

implementation

{ TMyControl }

constructor TMyControl.Create(AOwner:TComponent);
Begin
  Randomize;
  inherited Create(Aowner);
  ControlStyle:=ControlStyle - [csOpaque];
  BorderWidth := 10;
  Anchors := [akLeft, akTop, akBottom, akRight];
end;

procedure TMyControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle or WS_CLIPCHILDREN;
  with Params.WindowClass do
    style := style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure TMyControl.Paint;
begin
  Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
  Canvas.FillRect(Canvas.ClipRect);
end;

procedure TMyControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TMyControl.WMNCPaint(var Message: TWMNCPaint);
var
  DC: HDC;
  R: TRect;
begin
  Message.Result := 0;
  if BorderWidth > 0 then
  begin
    DC := GetWindowDC(Handle);
    try
      R := ClientRect;
      OffsetRect(R, BorderWidth, BorderWidth);
      ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
      SetRect(R, 0, 0, Width, Height);
      Brush.Color := clYellow;
      FillRect(DC, R, Brush.Handle);
    finally
      ReleaseDC(Handle, DC);
    end;
  end;
end;

end.

いくつかの注意：

  • 仮想として宣言する代わりに、CreateParamsをオーバーライドします。コンパイラの警告に注意してください（これは少し間違いだと思いますが）。
  • isEmptyRectもisSameRectもチェックする必要はありません。 ClipRectが空の場合、描画するものはありません。これは、Paintを直接呼び出すのではなく、常にInvalidateまたは同等のものを介して呼び出す理由でもあります。
  • AdjustClientRectは必要ありません。目的に応じて内部的に呼び出されます。

そしてボーナスとして、これはまさに私がチェスボードコンポーネントを描く方法です：

type
  TCustomChessBoard = class(TCustomControl)
  private
    FBorder: TChessBoardBorder;
    FOrientation: TBoardOrientation;
    FSquareSize: TSquareSize;
    procedure BorderChanged;
    procedure RepaintBorder;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function GetClientRect: TRect; override;
    procedure Paint; override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Repaint; override;
  end;

const
  ColCount = 8;
  RowCount = ColCount;

procedure TCustomChessBoard.BorderChanged;
begin
  RepaintBorder;
end;

constructor TCustomChessBoard.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
end;

procedure TCustomChessBoard.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params.WindowClass do
    style := style and not (CS_HREDRAW or CS_VREDRAW);
end;

function TCustomChessBoard.GetClientRect: TRect;
begin
  Result := Rect(0, 0, FSquareSize * ColCount, FSquareSize * RowCount);
end;

procedure TCustomChessBoard.Paint;

  procedure DrawSquare(Col, Row: Integer);
  var
    R: TRect;
  begin
    R := Bounds(Col * FSquareSize, Row * FSquareSize, FSquareSize, FSquareSize);
    Canvas.Brush.Color := Random(clWhite);
    Canvas.FillRect(R);
  end;

var
  iCol: Integer;
  iRow: Integer;
begin
  with Canvas.ClipRect do
    for iCol := (Left div FSquareSize) to (Right div FSquareSize) do
      for iRow := (Top div FSquareSize) to (Bottom div FSquareSize) do
        DrawSquare(iCol, iRow);
end;

procedure TCustomChessBoard.Repaint;
begin
  inherited Repaint;
  RepaintBorder;
end;

procedure TCustomChessBoard.RepaintBorder;
begin
  if Visible and HandleAllocated then
    Perform(WM_NCPAINT, 0, 0);
end;

procedure TCustomChessBoard.Resize;
begin
  Repaint;
  inherited Resize;
end;

procedure TCustomChessBoard.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TCustomChessBoard.WMNCPaint(var Message: TWMNCPaint);
var
  DC: HDC;
  R: TRect;
  R2: TRect;
  SaveFont: HFONT;

  procedure DoCoords(ShiftX, ShiftY: Integer; Alpha, Backwards: Boolean);
  const
    Format = DT_CENTER or DT_NOCLIP or DT_SINGLELINE or DT_VCENTER;
    CoordChars: array[Boolean, Boolean] of Char = (('1', '8'), ('A', 'H'));
  var
    i: Integer;
    C: Char;
  begin
    C := CoordChars[Alpha, Backwards];
    for i := 0 to ColCount - 1 do
    begin
      DrawText(DC, PChar(String(C)), 1, R, Format);
      DrawText(DC, PChar(String(C)), 1, R2, Format);
      if Backwards then
        Dec(C)
      else
        Inc(C);
      OffsetRect(R, ShiftX, ShiftY);
      OffsetRect(R2, ShiftX, ShiftY);
    end;
  end;

  procedure DoBackground(Thickness: Integer; AColor: TColor;
    DoPicture: Boolean);
  begin
    ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
    InflateRect(R, Thickness, Thickness);
    if DoPicture then
      with FBorder.Picture.Bitmap do
        BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
          Canvas.Handle, R.Left, R.Top, SRCCOPY)
    else
    begin
      Brush.Color := AColor;
      FillRect(DC, R, Brush.Handle);
    end;
  end;

begin
  Message.Result := 0;
  if BorderWidth > 0 then
    with FBorder do
    begin
      DC := GetWindowDC(Handle);
      try
        { BackGround }
        R := Rect(0, 0, Self.Width, Height);
        InflateRect(R, -Width, -Width);
        DoBackground(InnerWidth, InnerColor, False);
        DoBackground(MiddleWidth, MiddleColor, True);
        DoBackground(OuterWidth, OuterColor, False);
        { Coords }
        if CanShowCoords then
        begin
          ExtSelectClipRgn(DC, 0, RGN_COPY);
          SetBkMode(DC, TRANSPARENT);
          SetTextColor(DC, ColorToRGB(Font.Color));
          SaveFont := SelectObject(DC, Font.Handle);
          try
            { Left and right side }
            R := Bounds(OuterWidth, Width, MiddleWidth, FSquareSize);
            R2 := Bounds(Self.Width - OuterWidth - MiddleWidth, Width,
              MiddleWidth, FSquareSize);
            DoCoords(0, FSquareSize, FOrientation in [boRotate090, boRotate270],
              FOrientation in [boNormal, boRotate090]);
            { Top and bottom side }
            R := Bounds(Width, OuterWidth, FSquareSize, MiddleWidth);
            R2 := Bounds(Width, Height - OuterWidth - MiddleWidth, FSquareSize,
              MiddleWidth);
            DoCoords(FSquareSize, 0,  FOrientation in [boNormal, boRotate180],
              FOrientation in [boRotate090, boRotate180]);
          finally
            SelectObject(DC, SaveFont);
          end;
        end;
      finally
        ReleaseDC(Handle, DC);
      end;
    end;
end;

enter image description here

16
NGLN

ダブルバッファリングと派手な描画戦術は、話の半分にすぎません。残りの半分は、より重要な半分であると主張する人もいますが、無効にするコントロールの量を制限することです。

コメントでは、RedrawWindow(handle, @R, 0, rdw_Invalidate or rdw_Frame)を使用していると述べています。 R長方形を何に設定していますか？これをクライアント領域rectに設定すると、コントロールのクライアント領域全体が再描画されます。スクロールするときは、コントロールのごく一部、つまりスクロール方向の「トレーリングエッジ」にあるスライスだけを再描画する必要があります。 Windowsは、クライアント領域の残りの画面を画面にビットブリットして、既存のピクセルをスクロール方向に移動します。

また、スクロール時に完全な再描画を要求するようにウィンドウフラグを設定しているかどうかも確認してください。フラグ名をすぐに思い出せませんが、スクロールアクションがクライアント領域のスライスのみを無効にするように、フラグ名をオフにする必要があります。これがWindowsのデフォルトだと思います。

ハードウェアアクセラレーションによるグラフィックスを使用しても、少ない作業は多い作業よりも高速です。無効化された四角形を最小限に抑え、システムバス全体にプッシュするピクセル数を減らします。

19
dthorpe

それはかなり未解決の質問です。多くのヒントと答えがすでに与えられています。 2つ追加したいと思います。

  • ClientRectを完全にペイントする場合は、csOpaqueにControlStyleを含めます。
  • 除外CS_HREDRAWおよびCS_VREDRAW from Params.WindowClass.Style in CreateParams。

あなたは特にTScrollingWinControlを利用することに興味があるので、ここ数時間は私の計画コンポーネントのコードを減らして、必要なペイントとスクロールのコードだけを取得することに費やしました。これは単なる例であり、完全に機能したり、聖なるものとして意図されたりするわけではありませんが、いくつかのインスピレーションを提供する可能性があります。

unit Unit2;

interface

uses
  Classes, Controls, Windows, Messages, ComCtrls, Forms, Grids, Math, CommCtrl,
  SysUtils, StdCtrls, Graphics, Contnrs;

type
  TAwPlanGrid = class;

  TContainer = class(TWinControl)
  private
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure PaintWindow(DC: HDC); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TScrollEvent = procedure(Sender: TControlScrollBar) of object;

  TScroller = class(TScrollingWinControl)
  private
    FOnScroll: TScrollEvent;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure DoScroll(AScrollBar: TControlScrollBar);
    property OnScroll: TScrollEvent read FOnScroll write FOnScroll;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TColumn = class(TCustomControl)
  private
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure CMControlChange(var Message: TCMControlChange);
      message CM_CONTROLCHANGE;
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TTimeLineHeader = class(TCustomHeaderControl)
  protected
    procedure SectionResize(Section: THeaderSection); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TTimeLineGrid = class(TStringGrid)
  private
    FOnRowHeightsChanged: TNotifyEvent;
    FRowHeightsUpdating: Boolean;
  protected
    procedure Paint; override;
    procedure RowHeightsChanged; override;
    property OnRowHeightsChanged: TNotifyEvent read FOnRowHeightsChanged
      write FOnRowHeightsChanged;
  public
    constructor Create(AOwner: TComponent); override;
    function CanFocus: Boolean; override;
  end;

  TTimeLine = class(TContainer)
  private
    FHeader: TTimeLineHeader;
  protected
    TimeLineGrid: TTimeLineGrid;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  THighwayHeader = class(TCustomHeaderControl)
  private
    FSectionWidth: Integer;
    procedure SetSectionWidth(Value: Integer);
  protected
    function CreateSection: THeaderSection; override;
    procedure SectionResize(Section: THeaderSection); override;
    property SectionWidth: Integer read FSectionWidth write SetSectionWidth;
  public
    procedure AddSection(const AText: String);
    constructor Create(AOwner: TComponent); override;
  end;

  THighwayScroller = class(TScroller)
  private
    procedure WMHScroll(var Message: TWMScroll); message WM_HSCROLL;
    procedure WMPaint(var Message: TWMPaint); message WM_Paint;
    procedure WMVScroll(var Message: TWMScroll); message WM_VSCROLL;
  protected
    procedure PaintWindow(DC: HDC); override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  THighwayColumn = class(TColumn)
  end;

  THighwayColumns = class(TObject)
  private
    FHeight: Integer;
    FItems: TList;
    FParent: TWinControl;
    FWidth: Integer;
    function Add: THighwayColumn;
    function GetItem(Index: Integer): THighwayColumn;
    procedure SetHeight(Value: Integer);
    procedure SetWidth(Value: Integer);
  protected
    property Height: Integer read FHeight write SetHeight;
    property Items[Index: Integer]: THighwayColumn read GetItem; default;
    property Parent: TWinControl read FParent write FParent;
    property Width: Integer read FWidth write SetWidth;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  THighway = class(TContainer)
  private
    procedure HeaderSectionResized(HeaderControl: TCustomHeaderControl;
      Section: THeaderSection);
  protected
    Columns: THighwayColumns;
    Header: THighwayHeader;
    Scroller: THighwayScroller;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  TParkingHeader = class(TCustomHeaderControl)
  protected
    procedure SectionResize(Section: THeaderSection); override;
    procedure SetParent(AParent: TWinControl); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TParkingScroller = class(TScroller)
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TParkingColumn = class(TColumn)
  private
    FItemHeight: Integer;
    procedure SetItemHeight(Value: Integer);
  protected
    function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    property ItemHeight: Integer read FItemHeight write SetItemHeight;
  end;

  TParking = class(TContainer)
  protected
    Column: TParkingColumn;
    Header: TParkingHeader;
    Scroller: TParkingScroller;
    procedure PaintWindow(DC: HDC); override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TPlanItem = class(TGraphicControl)
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TPlanItems = class(TList)
  public
    procedure DayHeightChanged(OldDayHeight, NewDayHeight: Integer);
  end;

  TAwPlanGrid = class(TContainer)
  private
    FDayHeight: Integer;
    FHighway: THighway;
    FParking: TParking;
    FPlanItems: TPlanItems;
    FTimeLine: TTimeLine;
    function GetColWidth: Integer;
    procedure HighwayScrolled(Sender: TControlScrollBar);
    procedure SetColWidth(Value: Integer);
    procedure SetDayHeight(Value: Integer);
    procedure TimeLineRowHeightsChanged(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure MouseWheelHandler(var Message: TMessage); override;
    procedure Test;
    property ColWidth: Integer read GetColWidth;
    property DayHeight: Integer read FDayHeight;
  end;

function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG;
  Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; overload;
  external msimg32 name 'GradientFill';

implementation

function Round2(Value, Rounder: Integer): Integer;
begin
  if Rounder = 0 then Result := Value
  else Result := (Value div Rounder) * Rounder;
end;

// Layout:
//
// - PlanGrid
//   - TimeLine         - Highway            - Parking
//     - TimeLineHeader   - HighwayHeader      - ParkingHeader
//     - TimeLineGrid     - HighwayScroller    - ParkingScroller
//                          - HighwayColumns     - ParkingColumn
//                            - PlanItems          - PlanItems

const
  DaysPerWeek = 5;
  MaxParkingWidth = 300;
  MinColWidth = 50;
  MinDayHeight = 40;
  MinParkingWidth = 60;
  DefTimeLineWidth = 85;
  DividerColor = $0099A8AC;
  DefColWidth = 100;
  DefDayHeight = 48;
  DefWeekCount = 20;

{ TContainer }

constructor TContainer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
end;

procedure TContainer.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params.WindowClass do
    Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure TContainer.PaintWindow(DC: HDC);
begin
  { Eat inherited }
end;

procedure TContainer.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

{ TScroller }

constructor TScroller.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
  HorzScrollBar.Tracking := True;
  VertScrollBar.Tracking := True;
end;

procedure TScroller.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params.WindowClass do
    Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;

function TScroller.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
var
  Delta: Integer;
begin
  with VertScrollBar do
  begin
    Delta := Increment;
    if WheelDelta > 0 then
      Delta := -Delta;
    if ssCtrl in Shift then
      Delta := DaysPerWeek * Delta;
    Position := Min(Round2(Range - ClientHeight, Increment), Position + Delta);
  end;
  DoScroll(VertScrollBar);
  Result := True;
end;

procedure TScroller.DoScroll(AScrollBar: TControlScrollBar);
begin
  if Assigned(FOnScroll) then
    FOnScroll(AScrollBar);
end;

procedure TScroller.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

{ TColumn }

procedure TColumn.CMControlChange(var Message: TCMControlChange);
begin
  inherited;
  if Message.Inserting then
    Message.Control.Width := Width;
end;

constructor TColumn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
end;

procedure TColumn.Paint;
type
  PTriVertex = ^TTriVertex;
  TTriVertex = packed record
    X: DWORD;
    Y: DWORD;
    Red: Word;
    Green: Word;
    Blue: Word;
    Alpha: Word;
  end;
var
  Vertex: array[0..1] of TTriVertex;
  GRect: TGradientRect;
begin
  Vertex[0].X := 0;
  Vertex[0].Y := Canvas.ClipRect.Top;
  Vertex[0].Red := $DD00;
  Vertex[0].Green := $DD00;
  Vertex[0].Blue := $DD00;
  Vertex[0].Alpha := 0;
  Vertex[1].X := Width;
  Vertex[1].Y := Canvas.ClipRect.Bottom;
  Vertex[1].Red := $FF00;
  Vertex[1].Green := $FF00;
  Vertex[1].Blue := $FF00;
  Vertex[1].Alpha := 0;
  GRect.UpperLeft := 0;
  GRect.LowerRight := 1;
  GradientFill(Canvas.Handle, @Vertex, 2, @GRect, 1, GRADIENT_FILL_RECT_H);
end;

procedure TColumn.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

{ TTimeLineHeader }

constructor TTimeLineHeader.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
  DoubleBuffered := True;
  Sections.Add;
  Sections[0].MinWidth := 40;
  Sections[0].Width := DefTimeLineWidth;
  Sections[0].MaxWidth := DefTimeLineWidth;
  Sections[0].Text := '2011';
end;

procedure TTimeLineHeader.SectionResize(Section: THeaderSection);
begin
  if HasParent then
    Parent.Width := Section.Width;
  inherited SectionResize(Section);
end;

{ TTimeLineGrid }

function TTimeLineGrid.CanFocus: Boolean;
begin
  Result := False;
end;

constructor TTimeLineGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alCustom;
  Anchors := [akTop, akRight, akBottom];
  BorderStyle := bsNone;
  ColCount := 2;
  ColWidths[0] := 85;
  ControlStyle := [csOpaque];
  FixedCols := 1;
  FixedRows := 0;
  GridLineWidth := 0;
  Options := [goFixedHorzLine, goRowSizing];
  ScrollBars := ssNone;
  TabStop := False;
  Cells[0, 4] := 'Drag day height';
end;

procedure TTimeLineGrid.Paint;
begin
  inherited Paint;
  with Canvas do
    if ClipRect.Right >= Width - 1 then
    begin
      Pen.Color := DividerColor;
      MoveTo(Width - 1, ClipRect.Top);
      LineTo(Width - 1, ClipRect.Bottom);
    end;
end;

procedure TTimeLineGrid.RowHeightsChanged;
begin
  inherited RowHeightsChanged;
  if Assigned(FOnRowHeightsChanged) and (not FRowHeightsUpdating) then
    try
      FRowHeightsUpdating := True;
      FOnRowHeightsChanged(Self);
    finally
      FRowHeightsUpdating := False;
    end;
end;

{ TTimeLine }

constructor TTimeLine.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alLeft;
  Width := DefTimeLineWidth;
  Height := 100;
  FHeader := TTimeLineHeader.Create(Self);
  FHeader.Parent := Self;
  TimeLineGrid := TTimeLineGrid.Create(Self);
  TimeLineGrid.RowCount := DefWeekCount * DaysPerWeek;
  TimeLineGrid.SetBounds(0, FHeader.Height, Width, Height - FHeader.Height);
  TimeLineGrid.Parent := Self;
end;

{ THighwayHeader }

procedure THighwayHeader.AddSection(const AText: String);
begin
  with THeaderSection(Sections.Add) do
    Text := AText;
end;

constructor THighwayHeader.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alCustom;
  Anchors := [akLeft, akTop, akRight];
  ControlStyle := [csOpaque];
  DoubleBuffered := True;
  FullDrag := False;
end;

function THighwayHeader.CreateSection: THeaderSection;
begin
  Result := THeaderSection.Create(Sections);
  Result.MinWidth := MinColWidth;
  Result.Width := FSectionWidth;
end;

procedure THighwayHeader.SectionResize(Section: THeaderSection);
begin
  SectionWidth := Section.Width;
  inherited SectionResize(Section);
end;

procedure THighwayHeader.SetSectionWidth(Value: Integer);
var
  i: Integer;
begin
  if FSectionWidth <> Value then
  begin
    FSectionWidth := Value;
    for i := 0 to Sections.Count - 1 do
      Sections[i].Width := FSectionWidth;
  end;
end;

{ THighwayScroller }

constructor THighwayScroller.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alCustom;
  Anchors := [akLeft, akTop, akRight, akBottom];
  ControlStyle := [csOpaque];
end;

procedure THighwayScroller.PaintWindow(DC: HDC);
begin
  if ControlCount > 0 then
    ExcludeClipRect(DC, 0, 0, ControlCount * Controls[0].Width,
      Controls[0].Height);
  FillRect(DC, ClientRect, Brush.Handle);
end;

procedure THighwayScroller.Resize;
begin
  with VertScrollBar do
    Position := Round2(Position, Increment);
  DoScroll(HorzScrollBar);
  DoScroll(VertScrollBar);
  inherited Resize;
end;

procedure THighwayScroller.WMHScroll(var Message: TWMScroll);
begin
  inherited;
  DoScroll(HorzScrollBar);
end;

procedure THighwayScroller.WMPaint(var Message: TWMPaint);
begin
  ControlState := ControlState + [csCustomPaint];
  inherited;
  ControlState := ControlState - [csCustomPaint];
end;

procedure THighwayScroller.WMVScroll(var Message: TWMScroll);
var
  NewPos: Integer;
begin
  NewPos := Round2(Message.Pos, VertScrollBar.Increment);
  Message.Pos := NewPos;
  inherited;
  with VertScrollBar do
    if Position <> NewPos then
      Position := Round2(Position, Increment);
  DoScroll(VertScrollBar);
end;

{ THighwayColumns }

function THighwayColumns.Add: THighwayColumn;
var
  Index: Integer;
begin
  Result := THighwayColumn.Create(nil);
  Index := FItems.Add(Result);
  Result.SetBounds(Index * FWidth, 0, FWidth, FHeight);
  Result.Parent := FParent;
end;

constructor THighwayColumns.Create;
begin
  FItems := TObjectList.Create(True);
end;

destructor THighwayColumns.Destroy;
begin
  FItems.Free;
  inherited Destroy;
end;

function THighwayColumns.GetItem(Index: Integer): THighwayColumn;
begin
  Result := FItems[Index];
end;

procedure THighwayColumns.SetHeight(Value: Integer);
var
  i: Integer;
begin
  if FHeight <> Value then
  begin
    FHeight := Value;
    for i := 0 to FItems.Count - 1 do
      Items[i].Height := FHeight;
  end;
end;

procedure THighwayColumns.SetWidth(Value: Integer);
var
  i: Integer;
begin
  if FWidth <> Value then
  begin
    FWidth := Max(MinColWidth, Value);
    for i := 0 to FItems.Count - 1 do
      with Items[i] do
        SetBounds(Left + (FWidth - Width) * i, 0, FWidth, FHeight);
  end;
end;

{ THighway }

constructor THighway.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alClient;
  Width := 100;
  Height := 100;
  Header := THighwayHeader.Create(Self);
  Header.SetBounds(0, 0, Width, Header.Height);
  Header.OnSectionResize := HeaderSectionResized;
  Header.Parent := Self;
  Scroller := THighwayScroller.Create(Self);
  Scroller.SetBounds(0, Header.Height, Width, Height - Header.Height);
  Scroller.Parent := Self;
  Columns := THighwayColumns.Create;
  Columns.Parent := Scroller;
end;

destructor THighway.Destroy;
begin
  Columns.Free;
  inherited Destroy;
end;

procedure THighway.HeaderSectionResized(HeaderControl: TCustomHeaderControl;
  Section: THeaderSection);
begin
  Columns.Width := Section.Width;
  Scroller.HorzScrollBar.Increment := Columns.Width;
  Header.Left := -Scroller.HorzScrollBar.Position;
end;

{ TParkingHeader }

const
  BlindWidth = 2000;

constructor TParkingHeader.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alCustom;
  Anchors := [akLeft, akTop, akRight];
  ControlStyle := [csOpaque];
  DoubleBuffered := True;
  Sections.Add;
  Sections[0].Width := BlindWidth;
  Sections.Add;
  Sections[1].AutoSize := True;
  Sections[1].Text := 'Parked';
end;

procedure TParkingHeader.SectionResize(Section: THeaderSection);
begin
  if (Section.Index = 0) and HasParent then
  begin
    Parent.Width := Max(MinParkingWidth,
      Min(Parent.Width - Section.Width + BlindWidth, MaxParkingWidth));
    Section.Width := BlindWidth;
    Sections[1].Width := Parent.Width - 2;
  end;
  inherited SectionResize(Section);
end;

procedure TParkingHeader.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if HasParent then
  begin
    SetBounds(-BlindWidth + 2, 0, BlindWidth + Parent.Width, Height);
    Sections[1].Width := Parent.Width - 2;
  end;
end;

{ TParkingScroller }

constructor TParkingScroller.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alCustom;
  Anchors := [akLeft, akTop, akRight, akBottom];
  ControlStyle := [csOpaque];
  HorzScrollBar.Visible := False;
  VertScrollBar.Increment := DefDayHeight;
end;

{ TParkingColumn }

function TParkingColumn.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
  if HasParent then
    NewHeight := Max(Parent.Height, ControlCount * FItemHeight);
  Result := True;
end;

constructor TParkingColumn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alTop;
  AutoSize := True;
  FItemHeight := DefDayHeight;
end;

procedure TParkingColumn.SetItemHeight(Value: Integer);
var
  i: Integer;
begin
  if FItemHeight <> Value then
  begin
    FItemHeight := Value;
    for i := 0 to ControlCount - 1 do
      Controls[i].Height := FItemHeight;
    TScroller(Parent).VertScrollBar.Increment := FItemHeight;
  end;
end;

{ TParking }

constructor TParking.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Align := alRight;
  Width := 120;
  Height := 100;
  Header := TParkingHeader.Create(Self);
  Header.Parent := Self;
  Scroller := TParkingScroller.Create(Self);
  Scroller.SetBounds(1, Header.Height, Width, Height - Header.Height);
  Scroller.Parent := Self;
  Column := TParkingColumn.Create(Self);
  Column.Parent := Scroller;
end;

procedure TParking.PaintWindow(DC: HDC);
var
  R: TRect;
begin
  Brush.Color := DividerColor;
  SetRect(R, 0, Header.Height, 1, Height);
  FillRect(DC, R, Brush.Handle);
end;

procedure TParking.Resize;
begin
  Column.AdjustSize;
  inherited Resize;
end;

{ TPlanItem }

constructor TPlanItem.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Anchors := [akLeft, akTop, akRight];
  ControlStyle := [csOpaque];
  Color := Random(clWhite);
end;

procedure TPlanItem.Paint;
begin
  Canvas.Brush.Color := Color;
  Canvas.FillRect(Canvas.ClipRect);
end;

{ TPlanItems }

procedure TPlanItems.DayHeightChanged(OldDayHeight, NewDayHeight: Integer);
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
    with TPlanItem(Items[i]) do
      if not (Parent is TParkingColumn) then
      begin
        Top := Trunc(Top * (NewDayHeight / OldDayHeight));
        Height := Trunc(Height * (NewDayHeight / OldDayHeight));
      end;
end;

{ TAwPlanGrid }

constructor TAwPlanGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
  TabStop := True;
  Width := 400;
  Height := 200;
  FTimeLine := TTimeLine.Create(Self);
  FTimeLine.TimeLineGrid.OnRowHeightsChanged := TimeLineRowHeightsChanged;
  FTimeLine.Parent := Self;
  FParking := TParking.Create(Self);
  FParking.Parent := Self;
  FHighway := THighway.Create(Self);
  FHighway.Scroller.OnScroll := HighwayScrolled;
  FHighway.Parent := Self;
  FPlanItems := TPlanItems.Create;
  SetColWidth(DefColWidth);
  SetDayHeight(DefDayHeight);
  FHighway.Columns.Height := DefWeekCount * DaysPerWeek * FDayHeight;
end;

destructor TAwPlanGrid.Destroy;
begin
  FPlanItems.Free;
  inherited Destroy;
end;

function TAwPlanGrid.GetColWidth: Integer;
begin
  Result := FHighway.Columns.Width;
end;

procedure TAwPlanGrid.HighwayScrolled(Sender: TControlScrollBar);
begin
  if Sender.Kind = sbVertical then
    FTimeLine.TimeLineGrid.TopRow := Sender.Position div FDayHeight
  else
  begin
    FHighway.Header.Left := -Sender.Position;
    FHighway.Header.Width := FHighway.Width + Sender.Position;
  end;
end;

procedure TAwPlanGrid.MouseWheelHandler(var Message: TMessage);
var
  X: Integer;
begin
  with Message do
  begin
    X := ScreenToClient(SmallPointToPoint(TCMMouseWheel(Message).Pos)).X;
    if X >= FParking.Left then
      Result := FParking.Scroller.Perform(CM_MOUSEWHEEL, WParam, LParam)
    else
      Result := FHighway.Scroller.Perform(CM_MOUSEWHEEL, WParam, LParam);
  end;
  if Message.Result = 0 then
    inherited MouseWheelHandler(Message);
end;

procedure TAwPlanGrid.SetColWidth(Value: Integer);
begin
  if ColWidth <> Value then
  begin
    FHighway.Columns.Width := Value;
    FHighway.Header.SectionWidth := ColWidth;
    FHighway.Scroller.HorzScrollBar.Increment := ColWidth;
  end;
end;

procedure TAwPlanGrid.SetDayHeight(Value: Integer);
var
  OldDayHeight: Integer;
begin
  if FDayHeight <> Value then
  begin
    OldDayHeight := FDayHeight;
    FDayHeight := Max(MinDayHeight, Round2(Value, 4));
    FTimeLine.TimeLineGrid.DefaultRowHeight := FDayHeight;
    FHighway.Columns.Height := DefWeekCount * DaysPerWeek * FDayHeight;
    FHighway.Scroller.VertScrollBar.Increment := FDayHeight;
    FPlanItems.DayHeightChanged(OldDayHeight, FDayHeight);
  end;
end;

procedure TAwPlanGrid.Test;
var
  i: Integer;
  PlanItem: TPlanItem;
begin
  Randomize;
  Anchors := [akLeft, akTop, akBottom, akRight];
  for i := 0 to 3 do
    FHighway.Columns.Add;
  FHighway.Header.AddSection('Drag col width');
  FHighway.Header.AddSection('Column 2');
  FHighway.Header.AddSection('Column 3');
  FHighway.Header.AddSection('Column 4');
  for i := 0 to 9 do
  begin
    PlanItem := TPlanItem.Create(Self);
    PlanItem.Parent := FParking.Column;
    PlanItem.Top := i * DefDayHeight;
    PlanItem.Height := DefDayHeight;
    FPlanItems.Add(PlanItem);
  end;
  for i := 0 to 3 do
  begin
    PlanItem := TPlanItem.Create(Self);
    PlanItem.Parent := FHighway.Columns[i];
    PlanItem.Top := (i + 3) * DefDayHeight;
    PlanItem.Height := DefDayHeight;
    FPlanItems.Add(PlanItem);
  end;
  SetFocus;
end;

procedure TAwPlanGrid.TimeLineRowHeightsChanged(Sender: TObject);
var
  iRow: Integer;
begin
  with FTimeLine.TimeLineGrid do
    for iRow := 0 to RowCount - 1 do
      if RowHeights[iRow] <> DefaultRowHeight then
      begin
        SetDayHeight(RowHeights[iRow]);
        Break;
      end;
end;

end.

テストコード：

with TAwPlanGrid.Create(Self) do
begin
  SetBounds(10, 100, 600, 400);
  Parent := Self;
  Test;
end;

私の2カラット。

13
NGLN

私は議論を見て、実際にそれを採用しようとしました。同じピクセルを2回以上描画しないでください。

白い背景に赤い正方形を描いている場合は、すべてを白くペイントします赤い正方形が配置される場所を除く次に、赤い正方形を「塗りつぶし」ます。

enter image description here

ちらつきはなく、描画操作も少なくて済みます。

これは、 dthorp言及 のように、必要なものだけを無効にするの極端な例です。コントロールをスクロールしている場合は、ScrollWindowを使用して、グラフィックサブシステムに既存のものを移動させてから、fill in下部の欠落しているビットを移動します。

同じピクセルを複数回ペイントする必要がある場合があります。 ClearTypeテキストが最良の例です。 ClearTypeレンダリングでは、下のピクセルにアクセスする必要があります。つまり、haveを使用して領域を白で塗りつぶし、その上にテキストを描画します。

しかし、それでも通常は、レンダリングするテキストのrectsを測定し、どこでもclWhiteを埋めるelse、次にDrawTextfill in空の領域を-使用することで軽減できます。白いHBRUSH背景：

enter image description here

ただし、グラデーションや任意の既存のコンテンツにテキストを描画する場合、このトリックは機能しません。そのため、ちらつきが発生します。その場合、何らかの方法でバッファを2倍にする必要があります。 （ただし、ユーザーがリモートセッションにいる場合は、バッファを2倍にしないでください。描画が遅いよりも、ちらつきの方が適しています）。

Bonus Chatter：これで説明しました理由ユーザーがリモートデスクトップを実行しているときにコンテンツを2倍にしないでください（つまり、ターミナルサービス）、このInternet Explorerの詳細オプションの意味、機能、およびデフォルトでオフになっている理由がわかりました。

enter image description here

9
Ian Boyd