在 Delphi 中进行非闪烁、分段图形更新的最佳方法？
Posted
技术标签:
【中文标题】在 Delphi 中进行非闪烁、分段图形更新的最佳方法？【英文标题】：Best way to do non-flickering, segmented graphics updates in Delphi? 【发布时间】：2011-09-15 21:02:53 【问题描述】：我想我可以把它扔在那里然后问：我已经看到在图形效果方面完美无缺的 Delphi 控件。含义：无闪烁、分段更新（仅重绘控件中标记为脏的部分）和平滑滚动。
这些年来我编写了很多图形控件，所以我知道双缓冲、dib、bitblts 和所有“常见”的东西（如果可能，我总是使用 dib 来绘制所有内容，但有开销）。还了解 InvalidateRect 并检查 TCanvas.ClipRect 以获取需要更新的实际矩形。尽管有所有这些典型的解决方案，但我发现创建与开发人员 Express 或 Razed 组件相同质量的组件非常困难。如果图形是平滑的，你可以打赌滚动条（本机）闪烁，如果滚动条和框架是平滑的，你可以发誓在滚动过程中背景闪烁。
是否有标准的代码设置来处理这个问题？一种确保整个控件（包括控件的非客户区）顺利重绘的最佳实践？
例如，这里有一个“裸骨”控件，它采用高度进行分段更新（仅重绘需要的部分）。如果您在表单上创建它，请尝试在其上移动一个窗口，并观察它用颜色替换部分（参见绘制方法）。
是否有类似的基类可以处理非客户区重绘而不闪烁？
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;
更新
我只是想补充一点，诀窍是结合了以下几点：
-
绘制非客户区时ExcludeClipRect()，这样就不会与客户区的图形重叠
捕获 WMNCCalcSize 消息，而不是仅使用边框大小进行测量。我还必须为边缘尺寸取高度：
XEdge := GetSystemMetrics(SM_CXEDGE);
YEdge := GetSystemMetrics(SM_CYEDGE);
只要滚动条移动或调整大小，就使用以下标志调用 RedrawWindow()：
mRect:=ClientRect;
mFlags:=rdw_Invalidate
or RDW_NOERASE
or RDW_FRAME
or RDW_INTERNALPAINT
or RDW_NOCHILDREN;
RedrawWindow(windowhandle,@mRect,0,mFlags);
在 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;
感谢大家的帮助！
【问题讨论】：
我也写了很多可视化控件。在许多视觉效果有限的情况下，它可以完美地与剪辑矩形的巧妙使用配合使用，例如我的breadcrumb bar control。然而，在其他一些视觉反馈和动画很重要的情况下，我依赖双缓冲，这对我来说总是完美无缺。您可能想要手动响应WM_ERASEBKGND 消息，甚至可能想要手动处理双缓冲，方法是绘制到 TBitmap，然后在适合您时绘制到 BitBlt。
然而，没有适用于所有场景的“神奇”论坛，所以我怀疑这个问题会有很多有用的答案。
试试privat.rejbrand.se/asbutton.exe 来证明非常简单的 GDI 和双缓冲可以产生非常好的结果。
我想提一下，如果用户在远程桌面（即终端会话、远程会话）中运行，您不应该执行 双缓冲*/*blits，因为真的会减慢绘图速度。您想要在屏幕上绘制原始操作；发送 GDI 绘图命令比通过宽带发送位图要快得多。如果你真的关心你的用户，你也会禁用背景图片、渐变和动画。
我认为您的意思是“Raize”组件，而不是“Razed”。
【参考方案1】：
例如，这里有一个“裸骨”控件，它采用高度进行分段更新（仅重绘需要的部分）。如果您在表单上创建它，请尝试在其上移动一个窗口，并观察它用颜色替换部分（参见绘制方法）。
是否有类似的基类可以处理非客户区重绘而不闪烁？
嗯，您的 TMyControl 还没有非客户区。所以我添加了BorderWidth := 10;，现在它有了。 ;)
一般来说，默认 Windows 窗口的非客户区会自动绘制而不会闪烁，包括滚动条、标题等……（至少，我没有看到其他情况）。
如果要绘制自己的边框，则必须处理 WM_NCPAINT。请参阅此代码：
unit Unit2;
interface
uses
Classes, Controls, Messages, Windows, SysUtils, Graphics;
type
TMyControl = class(TCustomControl)
private
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
protected
procedure Paint; override;
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner:TComponent);override;
end;
implementation
TMyControl
constructor TMyControl.Create(AOwner:TComponent);
Begin
Randomize;
inherited Create(Aowner);
ControlStyle:=ControlStyle - [csOpaque];
BorderWidth := 10;
Anchors := [akLeft, akTop, akBottom, akRight];
end;
procedure TMyControl.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_CLIPCHILDREN;
with Params.WindowClass do
style := style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TMyControl.Paint;
begin
Canvas.Brush.Color := RGB(Random(255), Random(255), Random(255));
Canvas.FillRect(Canvas.ClipRect);
end;
procedure TMyControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TMyControl.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
R: TRect;
begin
Message.Result := 0;
if BorderWidth > 0 then
begin
DC := GetWindowDC(Handle);
try
R := ClientRect;
OffsetRect(R, BorderWidth, BorderWidth);
ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
SetRect(R, 0, 0, Width, Height);
Brush.Color := clYellow;
FillRect(DC, R, Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
end.
几点说明：
覆盖 CreateParams 而不是将其声明为虚拟的。注意编译器警告（尽管我认为/希望这是一个小错误）。 您不必检查isEmptyRect 或isSameRect。如果ClipRect 为空，则没有可绘制的内容。这也是为什么从不直接调用 Paint 而是始终通过 Invalidate 或等效方法调用的原因。
不需要AdjustClientRect。它会在需要时在内部调用。
作为奖励，这正是我绘制棋盘组件的方式：
type
TCustomChessBoard = class(TCustomControl)
private
FBorder: TChessBoardBorder;
FOrientation: TBoardOrientation;
FSquareSize: TSquareSize;
procedure BorderChanged;
procedure RepaintBorder;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
protected
procedure CreateParams(var Params: TCreateParams); override;
function GetClientRect: TRect; override;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
procedure Repaint; override;
end;
const
ColCount = 8;
RowCount = ColCount;
procedure TCustomChessBoard.BorderChanged;
begin
RepaintBorder;
end;
constructor TCustomChessBoard.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
end;
procedure TCustomChessBoard.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
style := style and not (CS_HREDRAW or CS_VREDRAW);
end;
function TCustomChessBoard.GetClientRect: TRect;
begin
Result := Rect(0, 0, FSquareSize * ColCount, FSquareSize * RowCount);
end;
procedure TCustomChessBoard.Paint;
procedure DrawSquare(Col, Row: Integer);
var
R: TRect;
begin
R := Bounds(Col * FSquareSize, Row * FSquareSize, FSquareSize, FSquareSize);
Canvas.Brush.Color := Random(clWhite);
Canvas.FillRect(R);
end;
var
iCol: Integer;
iRow: Integer;
begin
with Canvas.ClipRect do
for iCol := (Left div FSquareSize) to (Right div FSquareSize) do
for iRow := (Top div FSquareSize) to (Bottom div FSquareSize) do
DrawSquare(iCol, iRow);
end;
procedure TCustomChessBoard.Repaint;
begin
inherited Repaint;
RepaintBorder;
end;
procedure TCustomChessBoard.RepaintBorder;
begin
if Visible and HandleAllocated then
Perform(WM_NCPAINT, 0, 0);
end;
procedure TCustomChessBoard.Resize;
begin
Repaint;
inherited Resize;
end;
procedure TCustomChessBoard.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TCustomChessBoard.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
R: TRect;
R2: TRect;
SaveFont: HFONT;
procedure DoCoords(ShiftX, ShiftY: Integer; Alpha, Backwards: Boolean);
const
Format = DT_CENTER or DT_NOCLIP or DT_SINGLELINE or DT_VCENTER;
CoordChars: array[Boolean, Boolean] of Char = (('1', '8'), ('A', 'H'));
var
i: Integer;
C: Char;
begin
C := CoordChars[Alpha, Backwards];
for i := 0 to ColCount - 1 do
begin
DrawText(DC, PChar(String(C)), 1, R, Format);
DrawText(DC, PChar(String(C)), 1, R2, Format);
if Backwards then
Dec(C)
else
Inc(C);
OffsetRect(R, ShiftX, ShiftY);
OffsetRect(R2, ShiftX, ShiftY);
end;
end;
procedure DoBackground(Thickness: Integer; AColor: TColor;
DoPicture: Boolean);
begin
ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
InflateRect(R, Thickness, Thickness);
if DoPicture then
with FBorder.Picture.Bitmap do
BitBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,
Canvas.Handle, R.Left, R.Top, SRCCOPY)
else
begin
Brush.Color := AColor;
FillRect(DC, R, Brush.Handle);
end;
end;
begin
Message.Result := 0;
if BorderWidth > 0 then
with FBorder do
begin
DC := GetWindowDC(Handle);
try
BackGround
R := Rect(0, 0, Self.Width, Height);
InflateRect(R, -Width, -Width);
DoBackground(InnerWidth, InnerColor, False);
DoBackground(MiddleWidth, MiddleColor, True);
DoBackground(OuterWidth, OuterColor, False);
Coords
if CanShowCoords then
begin
ExtSelectClipRgn(DC, 0, RGN_COPY);
SetBkMode(DC, TRANSPARENT);
SetTextColor(DC, ColorToRGB(Font.Color));
SaveFont := SelectObject(DC, Font.Handle);
try
Left and right side
R := Bounds(OuterWidth, Width, MiddleWidth, FSquareSize);
R2 := Bounds(Self.Width - OuterWidth - MiddleWidth, Width,
MiddleWidth, FSquareSize);
DoCoords(0, FSquareSize, FOrientation in [boRotate090, boRotate270],
FOrientation in [boNormal, boRotate090]);
Top and bottom side
R := Bounds(Width, OuterWidth, FSquareSize, MiddleWidth);
R2 := Bounds(Width, Height - OuterWidth - MiddleWidth, FSquareSize,
MiddleWidth);
DoCoords(FSquareSize, 0, FOrientation in [boNormal, boRotate180],
FOrientation in [boRotate090, boRotate180]);
finally
SelectObject(DC, SaveFont);
end;
end;
finally
ReleaseDC(Handle, DC);
end;
end;
end;
【讨论】：
很好的例子！是的，我有几个错别字。我无法发布整个源代码，所以我最终写了一个简单的框架，只是为了说明一个开始可能是怎样的。我在控件中经常使用 AdjustClientRect，尤其是在复合布局中。我想我正在寻找的那一行是“Perform(WM_NCPAINT, 0, 0);”，今天晚些时候会检查一下——感谢所有信息！ Params.ExStyle := Params.ExStyle 或 WS_CLIPCHILDREN;如果我没记错的话，这一行实际上启用了 WS_EX_COMPOSITED。【参考方案2】：我已经看到了这个论点，并尝试在实践中使用它，即您永远不应该在相同的像素上多次绘制。
如果你在白色背景上画一个红色方块，那么你把所有东西都涂成白色除了红色方块会去的地方，然后你“填充”红色方块：
没有闪烁，并且您执行的绘图操作更少。
这是一个极端的例子，只使你必须做的事情无效，如dthorp mentions。如果您正在滚动控件，请使用ScrollWindow 让图形子系统移动已经存在的内容，然后填充底部缺少的位。
有时您必须多次绘制相同的像素； ClearType 文本就是最好的例子。 ClearType 渲染需要访问下面的像素 - 这意味着您将拥有用白色填充一个区域，然后在其上绘制您的文本。
但即便如此，通常也可以通过测量您要渲染的文本的rects 来缓解这种情况，在任何地方填写clWhite else，然后让DrawText 填写 空白区域 - 使用白色 HBRUSH 背景：
但是当在渐变或任意现有内容上绘制文本时，该技巧不起作用 - 因此会出现闪烁。在这种情况下，您必须以某种方式加倍缓冲。 （尽管如果用户处于远程会话中，则不要双缓冲 - 闪烁比慢速绘制要好）。
Bonus Chatter：现在我已经解释了为什么当用户通过远程桌面（即终端服务）运行时，您不应该双重缓冲内容，您现在了解此 Internet Explorer 高级选项的含义、作用以及默认关闭的原因：
【讨论】：
如果您要模仿 Raymond 的风格（为什么不这样做），那么您不妨借此机会在他讨论双缓冲和远程桌面的文章中添加一个链接，如果没记错的话，他为你纳税系列的一部分。 @David Heffernan：你注意到 Bonus chatter 的措辞了吗？ 是的，我对这些事情很警惕。 @David Heffernan @Ian Boyd，我也注意到了......所以我添加了这篇文章。 blogs.msdn.com/b/oldnewthing/archive/2006/01/03/508694.aspx【参考方案3】：这是一个非常开放的问题。已经给出了很多提示和答案。我想补充两个：
如果您完全绘制 ClientRect，请将csOpaque 包含在 ControlStyle 中，
从Params.WindowClass.Style 中的CreateParams 中排除CS_HREDRAW 和CS_VREDRAW。
由于您对在TScrollingWinControl 上绘图特别感兴趣，因此我花了最后几个小时来减少我的计划组件的代码，以仅获得必要的绘图和滚动代码。它只是一个示例，绝不是完全功能或神圣的，但它可能会提供一些灵感：
unit Unit2;
interface
uses
Classes, Controls, Windows, Messages, ComCtrls, Forms, Grids, Math, CommCtrl,
SysUtils, StdCtrls, Graphics, Contnrs;
type
TAwPlanGrid = class;
TContainer = class(TWinControl)
private
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
end;
TScrollEvent = procedure(Sender: TControlScrollBar) of object;
TScroller = class(TScrollingWinControl)
private
FOnScroll: TScrollEvent;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
procedure DoScroll(AScrollBar: TControlScrollBar);
property OnScroll: TScrollEvent read FOnScroll write FOnScroll;
public
constructor Create(AOwner: TComponent); override;
end;
TColumn = class(TCustomControl)
private
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CMControlChange(var Message: TCMControlChange);
message CM_CONTROLCHANGE;
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
TTimeLineHeader = class(TCustomHeaderControl)
protected
procedure SectionResize(Section: THeaderSection); override;
public
constructor Create(AOwner: TComponent); override;
end;
TTimeLineGrid = class(TStringGrid)
private
FOnRowHeightsChanged: TNotifyEvent;
FRowHeightsUpdating: Boolean;
protected
procedure Paint; override;
procedure RowHeightsChanged; override;
property OnRowHeightsChanged: TNotifyEvent read FOnRowHeightsChanged
write FOnRowHeightsChanged;
public
constructor Create(AOwner: TComponent); override;
function CanFocus: Boolean; override;
end;
TTimeLine = class(TContainer)
private
FHeader: TTimeLineHeader;
protected
TimeLineGrid: TTimeLineGrid;
public
constructor Create(AOwner: TComponent); override;
end;
THighwayHeader = class(TCustomHeaderControl)
private
FSectionWidth: Integer;
procedure SetSectionWidth(Value: Integer);
protected
function CreateSection: THeaderSection; override;
procedure SectionResize(Section: THeaderSection); override;
property SectionWidth: Integer read FSectionWidth write SetSectionWidth;
public
procedure AddSection(const AText: String);
constructor Create(AOwner: TComponent); override;
end;
THighwayScroller = class(TScroller)
private
procedure WMHScroll(var Message: TWMScroll); message WM_HSCROLL;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMVScroll(var Message: TWMScroll); message WM_VSCROLL;
protected
procedure PaintWindow(DC: HDC); override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
end;
THighwayColumn = class(TColumn)
end;
THighwayColumns = class(TObject)
private
FHeight: Integer;
FItems: TList;
FParent: TWinControl;
FWidth: Integer;
function Add: THighwayColumn;
function GetItem(Index: Integer): THighwayColumn;
procedure SetHeight(Value: Integer);
procedure SetWidth(Value: Integer);
protected
property Height: Integer read FHeight write SetHeight;
property Items[Index: Integer]: THighwayColumn read GetItem; default;
property Parent: TWinControl read FParent write FParent;
property Width: Integer read FWidth write SetWidth;
public
constructor Create;
destructor Destroy; override;
end;
THighway = class(TContainer)
private
procedure HeaderSectionResized(HeaderControl: TCustomHeaderControl;
Section: THeaderSection);
protected
Columns: THighwayColumns;
Header: THighwayHeader;
Scroller: THighwayScroller;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
TParkingHeader = class(TCustomHeaderControl)
protected
procedure SectionResize(Section: THeaderSection); override;
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent); override;
end;
TParkingScroller = class(TScroller)
public
constructor Create(AOwner: TComponent); override;
end;
TParkingColumn = class(TColumn)
private
FItemHeight: Integer;
procedure SetItemHeight(Value: Integer);
protected
function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;
public
constructor Create(AOwner: TComponent); override;
property ItemHeight: Integer read FItemHeight write SetItemHeight;
end;
TParking = class(TContainer)
protected
Column: TParkingColumn;
Header: TParkingHeader;
Scroller: TParkingScroller;
procedure PaintWindow(DC: HDC); override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
end;
TPlanItem = class(TGraphicControl)
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
TPlanItems = class(TList)
public
procedure DayHeightChanged(OldDayHeight, NewDayHeight: Integer);
end;
TAwPlanGrid = class(TContainer)
private
FDayHeight: Integer;
FHighway: THighway;
FParking: TParking;
FPlanItems: TPlanItems;
FTimeLine: TTimeLine;
function GetColWidth: Integer;
procedure HighwayScrolled(Sender: TControlScrollBar);
procedure SetColWidth(Value: Integer);
procedure SetDayHeight(Value: Integer);
procedure TimeLineRowHeightsChanged(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure MouseWheelHandler(var Message: TMessage); override;
procedure Test;
property ColWidth: Integer read GetColWidth;
property DayHeight: Integer read FDayHeight;
end;
function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG;
Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; overload;
external msimg32 name 'GradientFill';
implementation
function Round2(Value, Rounder: Integer): Integer;
begin
if Rounder = 0 then Result := Value
else Result := (Value div Rounder) * Rounder;
end;
// Layout:
//
// - PlanGrid
// - TimeLine - Highway - Parking
// - TimeLineHeader - HighwayHeader - ParkingHeader
// - TimeLineGrid - HighwayScroller - ParkingScroller
// - HighwayColumns - ParkingColumn
// - PlanItems - PlanItems
const
DaysPerWeek = 5;
MaxParkingWidth = 300;
MinColWidth = 50;
MinDayHeight = 40;
MinParkingWidth = 60;
DefTimeLineWidth = 85;
DividerColor = $0099A8AC;
DefColWidth = 100;
DefDayHeight = 48;
DefWeekCount = 20;
TContainer
constructor TContainer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
end;
procedure TContainer.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TContainer.PaintWindow(DC: HDC);
begin
Eat inherited
end;
procedure TContainer.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
TScroller
constructor TScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
HorzScrollBar.Tracking := True;
VertScrollBar.Tracking := True;
end;
procedure TScroller.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
function TScroller.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
var
Delta: Integer;
begin
with VertScrollBar do
begin
Delta := Increment;
if WheelDelta > 0 then
Delta := -Delta;
if ssCtrl in Shift then
Delta := DaysPerWeek * Delta;
Position := Min(Round2(Range - ClientHeight, Increment), Position + Delta);
end;
DoScroll(VertScrollBar);
Result := True;
end;
procedure TScroller.DoScroll(AScrollBar: TControlScrollBar);
begin
if Assigned(FOnScroll) then
FOnScroll(AScrollBar);
end;
procedure TScroller.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
TColumn
procedure TColumn.CMControlChange(var Message: TCMControlChange);
begin
inherited;
if Message.Inserting then
Message.Control.Width := Width;
end;
constructor TColumn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
end;
procedure TColumn.Paint;
type
PTriVertex = ^TTriVertex;
TTriVertex = packed record
X: DWORD;
Y: DWORD;
Red: WORD;
Green: WORD;
Blue: WORD;
Alpha: WORD;
end;
var
Vertex: array[0..1] of TTriVertex;
GRect: TGradientRect;
begin
Vertex[0].X := 0;
Vertex[0].Y := Canvas.ClipRect.Top;
Vertex[0].Red := $DD00;
Vertex[0].Green := $DD00;
Vertex[0].Blue := $DD00;
Vertex[0].Alpha := 0;
Vertex[1].X := Width;
Vertex[1].Y := Canvas.ClipRect.Bottom;
Vertex[1].Red := $FF00;
Vertex[1].Green := $FF00;
Vertex[1].Blue := $FF00;
Vertex[1].Alpha := 0;
GRect.UpperLeft := 0;
GRect.LowerRight := 1;
GradientFill(Canvas.Handle, @Vertex, 2, @GRect, 1, GRADIENT_FILL_RECT_H);
end;
procedure TColumn.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
TTimeLineHeader
constructor TTimeLineHeader.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
DoubleBuffered := True;
Sections.Add;
Sections[0].MinWidth := 40;
Sections[0].Width := DefTimeLineWidth;
Sections[0].MaxWidth := DefTimeLineWidth;
Sections[0].Text := '2011';
end;
procedure TTimeLineHeader.SectionResize(Section: THeaderSection);
begin
if HasParent then
Parent.Width := Section.Width;
inherited SectionResize(Section);
end;
TTimeLineGrid
function TTimeLineGrid.CanFocus: Boolean;
begin
Result := False;
end;
constructor TTimeLineGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akTop, akRight, akBottom];
BorderStyle := bsNone;
ColCount := 2;
ColWidths[0] := 85;
ControlStyle := [csOpaque];
FixedCols := 1;
FixedRows := 0;
GridLineWidth := 0;
Options := [goFixedHorzLine, goRowSizing];
ScrollBars := ssNone;
TabStop := False;
Cells[0, 4] := 'Drag day height';
end;
procedure TTimeLineGrid.Paint;
begin
inherited Paint;
with Canvas do
if ClipRect.Right >= Width - 1 then
begin
Pen.Color := DividerColor;
MoveTo(Width - 1, ClipRect.Top);
LineTo(Width - 1, ClipRect.Bottom);
end;
end;
procedure TTimeLineGrid.RowHeightsChanged;
begin
inherited RowHeightsChanged;
if Assigned(FOnRowHeightsChanged) and (not FRowHeightsUpdating) then
try
FRowHeightsUpdating := True;
FOnRowHeightsChanged(Self);
finally
FRowHeightsUpdating := False;
end;
end;
TTimeLine
constructor TTimeLine.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alLeft;
Width := DefTimeLineWidth;
Height := 100;
FHeader := TTimeLineHeader.Create(Self);
FHeader.Parent := Self;
TimeLineGrid := TTimeLineGrid.Create(Self);
TimeLineGrid.RowCount := DefWeekCount * DaysPerWeek;
TimeLineGrid.SetBounds(0, FHeader.Height, Width, Height - FHeader.Height);
TimeLineGrid.Parent := Self;
end;
THighwayHeader
procedure THighwayHeader.AddSection(const AText: String);
begin
with THeaderSection(Sections.Add) do
Text := AText;
end;
constructor THighwayHeader.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight];
ControlStyle := [csOpaque];
DoubleBuffered := True;
FullDrag := False;
end;
function THighwayHeader.CreateSection: THeaderSection;
begin
Result := THeaderSection.Create(Sections);
Result.MinWidth := MinColWidth;
Result.Width := FSectionWidth;
end;
procedure THighwayHeader.SectionResize(Section: THeaderSection);
begin
SectionWidth := Section.Width;
inherited SectionResize(Section);
end;
procedure THighwayHeader.SetSectionWidth(Value: Integer);
var
i: Integer;
begin
if FSectionWidth <> Value then
begin
FSectionWidth := Value;
for i := 0 to Sections.Count - 1 do
Sections[i].Width := FSectionWidth;
end;
end;
THighwayScroller
constructor THighwayScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight, akBottom];
ControlStyle := [csOpaque];
end;
procedure THighwayScroller.PaintWindow(DC: HDC);
begin
if ControlCount > 0 then
ExcludeClipRect(DC, 0, 0, ControlCount * Controls[0].Width,
Controls[0].Height);
FillRect(DC, ClientRect, Brush.Handle);
end;
procedure THighwayScroller.Resize;
begin
with VertScrollBar do
Position := Round2(Position, Increment);
DoScroll(HorzScrollBar);
DoScroll(VertScrollBar);
inherited Resize;
end;
procedure THighwayScroller.WMHScroll(var Message: TWMScroll);
begin
inherited;
DoScroll(HorzScrollBar);
end;
procedure THighwayScroller.WMPaint(var Message: TWMPaint);
begin
ControlState := ControlState + [csCustomPaint];
inherited;
ControlState := ControlState - [csCustomPaint];
end;
procedure THighwayScroller.WMVScroll(var Message: TWMScroll);
var
NewPos: Integer;
begin
NewPos := Round2(Message.Pos, VertScrollBar.Increment);
Message.Pos := NewPos;
inherited;
with VertScrollBar do
if Position <> NewPos then
Position := Round2(Position, Increment);
DoScroll(VertScrollBar);
end;
THighwayColumns
function THighwayColumns.Add: THighwayColumn;
var
Index: Integer;
begin
Result := THighwayColumn.Create(nil);
Index := FItems.Add(Result);
Result.SetBounds(Index * FWidth, 0, FWidth, FHeight);
Result.Parent := FParent;
end;
constructor THighwayColumns.Create;
begin
FItems := TObjectList.Create(True);
end;
destructor THighwayColumns.Destroy;
begin
FItems.Free;
inherited Destroy;
end;
function THighwayColumns.GetItem(Index: Integer): THighwayColumn;
begin
Result := FItems[Index];
end;
procedure THighwayColumns.SetHeight(Value: Integer);
var
i: Integer;
begin
if FHeight <> Value then
begin
FHeight := Value;
for i := 0 to FItems.Count - 1 do
Items[i].Height := FHeight;
end;
end;
procedure THighwayColumns.SetWidth(Value: Integer);
var
i: Integer;
begin
if FWidth <> Value then
begin
FWidth := Max(MinColWidth, Value);
for i := 0 to FItems.Count - 1 do
with Items[i] do
SetBounds(Left + (FWidth - Width) * i, 0, FWidth, FHeight);
end;
end;
THighway
constructor THighway.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alClient;
Width := 100;
Height := 100;
Header := THighwayHeader.Create(Self);
Header.SetBounds(0, 0, Width, Header.Height);
Header.OnSectionResize := HeaderSectionResized;
Header.Parent := Self;
Scroller := THighwayScroller.Create(Self);
Scroller.SetBounds(0, Header.Height, Width, Height - Header.Height);
Scroller.Parent := Self;
Columns := THighwayColumns.Create;
Columns.Parent := Scroller;
end;
destructor THighway.Destroy;
begin
Columns.Free;
inherited Destroy;
end;
procedure THighway.HeaderSectionResized(HeaderControl: TCustomHeaderControl;
Section: THeaderSection);
begin
Columns.Width := Section.Width;
Scroller.HorzScrollBar.Increment := Columns.Width;
Header.Left := -Scroller.HorzScrollBar.Position;
end;
TParkingHeader
const
BlindWidth = 2000;
constructor TParkingHeader.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight];
ControlStyle := [csOpaque];
DoubleBuffered := True;
Sections.Add;
Sections[0].Width := BlindWidth;
Sections.Add;
Sections[1].AutoSize := True;
Sections[1].Text := 'Parked';
end;
procedure TParkingHeader.SectionResize(Section: THeaderSection);
begin
if (Section.Index = 0) and HasParent then
begin
Parent.Width := Max(MinParkingWidth,
Min(Parent.Width - Section.Width + BlindWidth, MaxParkingWidth));
Section.Width := BlindWidth;
Sections[1].Width := Parent.Width - 2;
end;
inherited SectionResize(Section);
end;
procedure TParkingHeader.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
if HasParent then
begin
SetBounds(-BlindWidth + 2, 0, BlindWidth + Parent.Width, Height);
Sections[1].Width := Parent.Width - 2;
end;
end;
TParkingScroller
constructor TParkingScroller.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alCustom;
Anchors := [akLeft, akTop, akRight, akBottom];
ControlStyle := [csOpaque];
HorzScrollBar.Visible := False;
VertScrollBar.Increment := DefDayHeight;
end;
TParkingColumn
function TParkingColumn.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;
begin
if HasParent then
NewHeight := Max(Parent.Height, ControlCount * FItemHeight);
Result := True;
end;
constructor TParkingColumn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alTop;
AutoSize := True;
FItemHeight := DefDayHeight;
end;
procedure TParkingColumn.SetItemHeight(Value: Integer);
var
i: Integer;
begin
if FItemHeight <> Value then
begin
FItemHeight := Value;
for i := 0 to ControlCount - 1 do
Controls[i].Height := FItemHeight;
TScroller(Parent).VertScrollBar.Increment := FItemHeight;
end;
end;
TParking
constructor TParking.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Align := alRight;
Width := 120;
Height := 100;
Header := TParkingHeader.Create(Self);
Header.Parent := Self;
Scroller := TParkingScroller.Create(Self);
Scroller.SetBounds(1, Header.Height, Width, Height - Header.Height);
Scroller.Parent := Self;
Column := TParkingColumn.Create(Self);
Column.Parent := Scroller;
end;
procedure TParking.PaintWindow(DC: HDC);
var
R: TRect;
begin
Brush.Color := DividerColor;
SetRect(R, 0, Header.Height, 1, Height);
FillRect(DC, R, Brush.Handle);
end;
procedure TParking.Resize;
begin
Column.AdjustSize;
inherited Resize;
end;
TPlanItem
constructor TPlanItem.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Anchors := [akLeft, akTop, akRight];
ControlStyle := [csOpaque];
Color := Random(clWhite);
end;
procedure TPlanItem.Paint;
begin
Canvas.Brush.Color := Color;
Canvas.FillRect(Canvas.ClipRect);
end;
TPlanItems
procedure TPlanItems.DayHeightChanged(OldDayHeight, NewDayHeight: Integer);
var
i: Integer;
begin
for i := 0 to Count - 1 do
with TPlanItem(Items[i]) do
if not (Parent is TParkingColumn) then
begin
Top := Trunc(Top * (NewDayHeight / OldDayHeight));
Height := Trunc(Height * (NewDayHeight / OldDayHeight));
end;
end;
TAwPlanGrid
constructor TAwPlanGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
TabStop := True;
Width := 400;
Height := 200;
FTimeLine := TTimeLine.Create(Self);
FTimeLine.TimeLineGrid.OnRowHeightsChanged := TimeLineRowHeightsChanged;
FTimeLine.Parent := Self;
FParking := TParking.Create(Self);
FParking.Parent := Self;
FHighway := THighway.Create(Self);
FHighway.Scroller.OnScroll := HighwayScrolled;
FHighway.Parent := Self;
FPlanItems := TPlanItems.Create;
SetColWidth(DefColWidth);
SetDayHeight(DefDayHeight);
FHighway.Columns.Height := DefWeekCount * DaysPerWeek * FDayHeight;
end;
destructor TAwPlanGrid.Destroy;
begin
FPlanItems.Free;
inherited Destroy;
end;
function TAwPlanGrid.GetColWidth: Integer;
begin
Result := FHighway.Columns.Width;
end;
procedure TAwPlanGrid.HighwayScrolled(Sender: TControlScrollBar);
begin
if Sender.Kind = sbVertical then
FTimeLine.TimeLineGrid.TopRow := Sender.Position div FDayHeight
else
begin
FHighway.Header.Left := -Sender.Position;
FHighway.Header.Width := FHighway.Width + Sender.Position;
end;
end;
procedure TAwPlanGrid.MouseWheelHandler(var Message: TMessage);
var
X: Integer;
begin
with Message do
begin
X := ScreenToClient(SmallPointToPoint(TCMMouseWheel(Message).Pos)).X;
if X >= FParking.Left then
Result := FParking.Scroller.Perform(CM_MOUSEWHEEL, WParam, LParam)
else
Result := FHighway.Scroller.Perform(CM_MOUSEWHEEL, WParam, LParam);
end;
if Message.Result = 0 then
inherited MouseWheelHandler(Message);
end;
procedure TAwPlanGrid.SetColWidth(Value: Integer);
begin
if ColWidth <> Value then
begin
FHighway.Columns.Width := Value;
FHighway.Header.SectionWidth := ColWidth;
FHighway.Scroller.HorzScrollBar.Increment := ColWidth;
end;
end;
procedure TAwPlanGrid.SetDayHeight(Value: Integer);
var
OldDayHeight: Integer;
begin
if FDayHeight <> Value then
begin
OldDayHeight := FDayHeight;
FDayHeight := Max(MinDayHeight, Round2(Value, 4));
FTimeLine.TimeLineGrid.DefaultRowHeight := FDayHeight;
FHighway.Columns.Height := DefWeekCount * DaysPerWeek * FDayHeight;
FHighway.Scroller.VertScrollBar.Increment := FDayHeight;
FPlanItems.DayHeightChanged(OldDayHeight, FDayHeight);
end;
end;
procedure TAwPlanGrid.Test;
var
i: Integer;
PlanItem: TPlanItem;
begin
Randomize;
Anchors := [akLeft, akTop, akBottom, akRight];
for i := 0 to 3 do
FHighway.Columns.Add;
FHighway.Header.AddSection('Drag col width');
FHighway.Header.AddSection('Column 2');
FHighway.Header.AddSection('Column 3');
FHighway.Header.AddSection('Column 4');
for i := 0 to 9 do
begin
PlanItem := TPlanItem.Create(Self);
PlanItem.Parent := FParking.Column;
PlanItem.Top := i * DefDayHeight;
PlanItem.Height := DefDayHeight;
FPlanItems.Add(PlanItem);
end;
for i := 0 to 3 do
begin
PlanItem := TPlanItem.Create(Self);
PlanItem.Parent := FHighway.Columns[i];
PlanItem.Top := (i + 3) * DefDayHeight;
PlanItem.Height := DefDayHeight;
FPlanItems.Add(PlanItem);
end;
SetFocus;
end;
procedure TAwPlanGrid.TimeLineRowHeightsChanged(Sender: TObject);
var
iRow: Integer;
begin
with FTimeLine.TimeLineGrid do
for iRow := 0 to RowCount - 1 do
if RowHeights[iRow] <> DefaultRowHeight then
begin
SetDayHeight(RowHeights[iRow]);
Break;
end;
end;
end.
测试代码：
with TAwPlanGrid.Create(Self) do
begin
SetBounds(10, 100, 600, 400);
Parent := Self;
Test;
end;
我的 2 cts。
【讨论】：
你提到标志很有趣，我昨晚在想那些标志-感谢示例代码，我下班后试试！【参考方案4】：双重缓冲和花哨的绘图策略只是故事的一半。另一半，有些人会认为更关键的一半是限制你的控制无效的程度。
在您的 cmets 中，您提到您使用 RedrawWindow(handle, @R, 0, rdw_Invalidate or rdw_Frame)。您将R 矩形设置为什么？如果您将其设置为您的客户区矩形，那么您将重绘控件的整个客户区。滚动时，只需要重绘控件的一小部分——滚动方向“后沿”处的切片。 Windows 会将客户区屏幕的其余部分按位传送到屏幕，以在滚动方向上移动现有像素。
还要检查您是否已将窗口标志设置为需要在滚动时完全重绘。我不记得标志名称，但您希望它们关闭，以便滚动操作只会使您的客户区域的一部分无效。我相信这是 Windows 的默认设置。
即使使用硬件加速图形，更少的工作也比更多的工作更快。将您的无效矩形降至绝对最小值，并减少您在系统总线上推送的像素数。
【讨论】：
重绘窗口调用是强制非客户区（例如边框）无效的调用。这样做有更好的要求吗？请记住，NCA 位于 clientrect 之外 我完全同意其余的。我试图尽量减少使用 invalidate/invalidaterect。 Jon：尝试只使用 rdw_Frame 标志。我有一个模糊的回忆（自上次 GDI 工作以来已经 10 年了！）rdw_Invalidate 使客户区无效，而 rdw_Frame 使 NCA 无效。如果您只想使 NCA 失效，则仅使用 rdw_Frame。 顺便说一句，你为什么要让 NCA 失效？ 因为我没有将标尺作为画布的一部分，而是将它们隔离在框架中 - 这样画布缩放不会受到影响以上是关于在 Delphi 中进行非闪烁、分段图形更新的最佳方法？的主要内容，如果未能解决你的问题，请参考以下文章
Delphi 11 Alexandria PaintBox 在 RDP 中闪烁
WebView2 (TEdgeBrowser) 更新了 Delphi 界面（例如 ICoreWebView2Controller2）
在我的 PyQt5 GUI（非基于 Web 的应用程序）中嵌入图形（数据可视化）的最佳方式