Best way to do non-flickering, segmented graphics updates in Delphi? - delphi

Question

I thought I could just throw this out there and just ask: I have seen Delphi controls that are flawless in terms of graphical effects. Meaning: no flickering, sectioned updates (only redraw the section of a control that is marked as dirty) and smooth scrolling.
I have coded a lot of graphical controls over the years, so I know about double buffering, dibs, bitblts and all the "common" stuff (I always use dibs to draw everything if possible, but there is an overhead). Also know about InvalidateRect and checking TCanvas.ClipRect for the actual rect that needs to be updated. Despite all these typical solutions, I find it very difficult to create the same quality components as say - Developer Express or Razed Components. If the graphics is smooth you can bet the scrollbars (native) flicker, and if the scrollbars and frame is smooth you can swear the background flickers during scrolling.
Is there a standard setup of code to handle this? A sort of best practises that ensures smooth redraws of the entire control -- including the non-client area of a control?
For instance, here is a "bare bone" control which take height for segmented updates (only redraw what is needed). If you create it on a form, try moving a window over it, and watch it replace the parts with colors (see paint method).
Does anyone have a similar base class that can handle non client area redraws without flickering?
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;
Updated
I just wanted to add that what did the trick was a combination of:
ExcludeClipRect() when drawing the non-clientarea, so you dont overlap with the graphics in the clientarea
Catching the WMNCCalcSize message rather than just using the bordersize for measurements. I also had to take height for the edge sizes:
XEdge := GetSystemMetrics(SM_CXEDGE);
YEdge := GetSystemMetrics(SM_CYEDGE);
Calling RedrawWindow() with the following flags whenever you have scrollbars that have moved or a resize:
mRect:=ClientRect;
mFlags:=rdw_Invalidate
or RDW_NOERASE
or RDW_FRAME
or RDW_INTERNALPAINT
or RDW_NOCHILDREN;
RedrawWindow(windowhandle,#mRect,0,mFlags);
When updating the background during the Paint() method, avoid drawing over possible child objects, like this (see the RDW_NOCHILDREN mentioned above):
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;
Thanks for the help guys!

Answer 1

Double buffering and fancy drawing tactics are only half the story. The other half, some would argue the more critical half, is to limit how much of your control is invalidated.
In your comments, you mention that you use RedrawWindow(handle, #R, 0, rdw_Invalidate or rdw_Frame). What are you setting the R rectangle to? If you set it to your client area rect, then you are redrawing the entire client area of your control. When scrolling, only a small portion of your control needs to be redrawn - the slice at the "trailing edge" of the scroll direction. Windows will bitblit the rest of the client area screen to screen to move the existing pixels over in the scroll direction.
Also check whether you have set your window flags to require full redraw on scroll. I don't recall the flag names offhand, but you want them turned off so that scroll actions only invalidate a slice of your client area. I believe this is the Windows default.
Even with hardware accelerated graphics, less work is faster than more work. Get your invalidate rects down to the absolute minimum and reduce the number of pixels you're pushing across the system bus.

Answer 2

For instance, here is a "bare bone" control which take height for segmented updates (only redraw what is needed). If you create it on a form, try moving a window over it, and watch it replace the parts with colors (see paint method).
Does anyone have a similar base class that can handle non client area redraws without flickering?
Well, your TMyControl does not have a non client area (yet). So I added BorderWidth := 10; and now it has. ;)
In general, the non client area's of default Windows windows are automatically painted without flickering, including scrollbars, titles, etc... (at least, I have not witnessed otherwise).
If you want to paint your own border, you have to handle WM_NCPAINT. See this code:
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.
A few remarks:
Override CreateParams instead of declaring it virtual. Mind the compiler warning (though I think/hope this is a little mistake).
You don't have to check for isEmptyRect nor isSameRect. If ClipRect is empty, then there is nothing to draw. This is also the reason why never to call Paint directly, but always through Invalidate or equivalent.
AdjustClientRect is not needed. It is called internally when needed for its purpose.
And as a bonus, this is exactly how I draw a chessbord component:
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 3

That is quite an open question. Much tips and answers have already been given. I would like to add two:
Include csOpaque in ControlStyle if you paint ClientRect fully,
Exclude CS_HREDRAW and CS_VREDRAW from Params.WindowClass.Style in CreateParams.
Since you are especially interested in drawing on TScrollingWinControl, I spend the last couple of hours on reducing the code of a planning component of mine, to get only the necessary painting and scrolling code. It is just an example and by no means fully functional or meant as holy, but it might provide some inspiration:
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 code:
with TAwPlanGrid.Create(Self) do
begin
SetBounds(10, 100, 600, 400);
Parent := Self;
Test;
end;
My 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 (i.e. Terminal Services), you now know what this Internet Explorer advanced option means, what it does, and why it is off by default: