在Delphi中做非闪烁，分段graphics更新的最佳方法？

我想我可以把它扔在那里，只是问：我已经看到了delphi的控制，在graphics效果方面是完美无缺的。 含义：不闪烁，分段更新（只重绘标记为脏的控件部分）和平滑滚动。

我已经编写了很多年的graphics控件，所以我知道双缓冲，dibs，bitblts和所有的“常见”的东西（我总是使用dibs如果可能绘制一切，但有一个开销）。 也知道InvalidateRect和检查TCanvas.ClipRect为需要更新的实际矩形。 尽pipe所有这些典型的解决scheme，我发现很难创build相同的质量组件，如说 – Developer Express或Razed组件。 如果graphics平滑，则可以下注滚动条（本地）闪烁，如果滚动条和框架平滑，则可以在滚动期间发誓背景闪烁。

有没有一个标准的代码设置来处理这个？ 一种确保整个控制顺利重新绘制的最佳实践 – 包括控制的非客户区域？

例如，这里是一个“裸骨”控制，它为分段更新提供高度（只重绘需要的）。 如果您在窗体上创build它，请尝试将窗口移动到窗体上，并用颜色replace部件（请参阅绘画方法）。

有没有人有类似的基类，可以处理非客户区重绘没有闪烁？

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（）绘制非客户区时，所以不要与客户区中的graphics重叠

2. 捕获WMNCCalcSize消息，而不是仅使用边界大小进行测量。 我也不得不采取边缘大小的高度：

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

3. 每当有滚动条移动或resize时，使用以下标志调用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; 

谢谢你的帮助！

Answer 1

例如，这里是一个“裸骨”控制，它为分段更新提供高度（只重绘需要的）。 如果您在窗体上创build它，请尝试将窗口移动到窗体上，并用颜色replace部件（请参阅绘画方法）。

有没有人有一个类似的基类，可以处理非客户区重绘没有闪烁？

那么，你的TMyControl没有一个非客户区域（还）。 所以我加了BorderWidth := 10; 现在它已经。 ;）

一般来说，默认Windows窗口的非客户端区域会自动绘制而不闪烁，包括滚动条，标题等等（至less，我没有目睹过其他情况）。

如果你想绘制自己的边框，你必须处理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; 

Answer 2

双缓冲和奇特的绘画战术只是故事的一半。 另一半，有些人会认为更关键的一半是限制你的控制失效。

在你的评论中，你提到你使用RedrawWindow(handle, @R, 0, rdw_Invalidate or rdw_Frame) 。 你把R矩形设置成什么？ 如果您将其设置为您的客户区域矩形，那么您正在重绘控件的整个客户区域。 滚动时，只需要重新绘制一小部分控件 – 滚动方向“尾部”处的切片。 Windows会将客户区域屏幕的其余部分截断以屏幕移动滚动方向上的现有像素。

同时检查你是否已经设置了窗口标志，要求滚动时完全重绘。 我不记得国旗的名字，但你希望他们closures，以便滚动操作只会使您的客户区的一个片断无效。 我相信这是Windows的默认设置。

即使使用硬件加速的graphics，更less的工作也比更多的工作更快。 将您的无效reflection降至最低，并减less您在系统总线上推动的像素数量。

Answer 3

这是一个悬而未决的问题。 已经提供了许多技巧和答案。 我想补充两点：

• 如果完全绘制ClientRect，请在ControlStyle包含csOpaque ，
• 从CreateParams Params.WindowClass.Style中排除CS_HREDRAW和CS_VREDRAW 。

由于您特别感兴趣的是使用TScrollingWinControl ，因此我花了几个小时的时间来减less我的规划组件的代码，以获得必要的绘制和滚动代码。 这仅仅是一个例子，并不完全是function性的或者是神圣的，但是它可能会提供一些启示：

 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. 

testing代码：

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

我的2 cts。

Answer 4

i have seen the argument, and try to employ it in practice, that you should never draw over the same pixels more than once.

If you're drawing a red square on a white background then you paint everything white except where the red square will go , then you "fill in" the red square:

There's no flicker, and you're doing fewer drawing operations.

That is an extreme example of only invalidate what you have to , as dthorp mentions . If you're scrolling a control, use ScrollWindow to have the graphics subsystem move what's already there, and then just fill in the missing bit at the bottom.

There are going to be times where you have to paint the same pixels multiple times; ClearType text is the best example. ClearType rendering requires access to the pixels underneath – which means you're going to have to fill an area with white, then draw your text over it.

But even that can usually be mitigated by measuring the rects of the text you're going to render, fill clWhite everywhere else , then have DrawText fill in the empty areas – using a white HBRUSH background:

But that trick cannot work when drawing text on a gradient, or arbitrary existing content – so there will be flicker. In that case you have to double buffer in some way. (Although don't double buffer if the user is in a remote session – flickering is better than slow drawing).

---

Bonus Chatter : Now that i've explained why you shouldn't double buffer content when the user is running though Remote Desktop (ie Terminal Services), you now know what this Internet Explorer advanced option means, what it does, and why it is off by default: