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

Question

I thought I could just throw it away and just ask: I saw Delphi controls that are flawless in terms of graphic effects. Meaning: No flickering, partitioned updates (only redrawing the section of the control marked as dirty), and smooth scrolling.

Over the years, I have coded many graphical controls, so I know about double buffering, dibs, bitblts, and all the “common” materials (I always use dibs to draw everything if possible, but there is overhead). Also be aware of InvalidateRect and check the TCanvas.ClipRect for the actual rectangle that needs to be updated. Despite all these typical solutions, it’s very difficult for me to create the same quality components that I can say - Developer Express or Razed Components. If the graphics are smooth, you can set the scroll bar (native) to flicker, and if the scroll bars and frames are smooth, you can swear that the background flickers while scrolling.

Is there a standard code setting to handle this? Some kind of best practice that provides a smooth redraw of the entire control - including the non-client area of ​​the control?

For example, here is a bare-bone control that takes up height for segmented updates (just redraw what is needed). If you create it on a form, try moving the window above it and see how it replaces parts with colors (see Drawing Method).

Does anyone have a similar base class that can handle non-client areas without modification?

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; 

Update

I just wanted to add that the trick was a combination:

• ExcludeClipRect () when drawing non-clientarea, so you do not overlap the graphics in the client area

• Capturing a WMNCCalcSize message, not just using borders for measurements. I also had to take height for edge sizes:

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

• Call RedrawWindow () with the following flags when you have scrollbars moved or resized:

   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 painting on possible child objects, for example (see 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 helping the guys!

Answer 1

For example, here is a bare-bone control that takes up height for segmented updates (just redraw what is needed). If you create it on a form, try moving the window above it and see how it replaces parts with colors (see Drawing Method).

Does anyone have a similar base class that can handle non-client areas without modification?

Well, your TMyControl does not have an area without a client (yet). So I added BorderWidth := 10; , and now he has;)

In the general case, the area without client windows by default is automatically painted by Windows without flickering, including scrollbars, headers, etc. (at least I haven't seen it yet).

If you want to draw 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 notes:

• Override CreateParams instead of declaring virtual. Pay attention to the compiler warning (although I think / hope this is a small error).
• You do not need to check isEmptyRect and isSameRect . If ClipRect empty, then there is nothing to draw. This is also the reason you should never access Paint directly, but always through Invalidate or the equivalent.
• AdjustClientRect is not required. He is called internally when necessary for his purposes.

And as a bonus, that’s how I draw the component of a chess piece:

 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

Double buffering and fancy drawing tactics are just half the story. The other half, some argue that the more important half, is to limit how invalid your control is.

Your comments mention that you are using RedrawWindow(handle, @R, 0, rdw_Invalidate or rdw_Frame) . What do you set for the rectangle R ? If you configured it on your client area, then you redraw the entire client area of ​​your control. When scrolling, you need to edit only a small part of your control - a slice at the "trailing edge" of the scroll direction. Windows will bill the rest of the client area screen for the screen to move existing pixels in the scroll direction.

Also check if the checkboxes of the window are set to fully redraw the scroll. I don’t remember the names of the flags, but you want them to turn off, so the scroll action only robs areas of your client space. I believe this is the default Windows.

Even with hardware accelerated graphics, less work is faster than more work. Receive invalid corrections to an absolute minimum and reduce the number of pixels that you click on the system bus.

Answer 3

This is a fairly open question. Many tips and answers have already been given. I would like to add two:

• Include csOpaque in ControlStyle if you fully draw ClientRect,
• Exclude CS_HREDRAW and CS_VREDRAW from Params.WindowClass.Style in Params.WindowClass.Style .

Since you are particularly interested in drawing on TScrollingWinControl , I have TScrollingWinControl last couple of hours reducing the code of my planning component to get only the necessary code for drawing and scrolling. This is just an example and by no means fully functional or implied as a saint, but it can give 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. 

:

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

2 cts.

Answer 4

, .

, , , , "" :

, .

, , dthorp . , ScrollWindow , , , .

, , ; ClearType - . ClearType - , , , .

, rects , , clWhite , DrawText - HBRUSH :

- . - . ( , - , ).

---

. , , Remote Desktop (, ), , Internet Explorer , , :