在Delphi中进行非闪烁，分段图形更新的最佳方法？ [英] Best way to do non-flickering, segmented graphics updates in Delphi?

问题描述

我以为我可以把它丢在那里，只是问：我看到Delphi控件在图形效果方面是完美的。意义：没有闪烁的分段更新（只重绘一个被标记为脏的控件的部分）和平滑滚动。

我编码了很多图形控件多年，所以我知道双缓冲，二重，bitblts和所有的常见的东西（我总是使用dibs绘制一切，如果可能，但有一个开销）。还要知道InvalidateRect并检查TCanvas.ClipRect是否需要更新的实际rect。尽管有这些典型的解决方案，我发现很难创建与开发者Express或Razed Components相同的质量组件。如果图形平滑，您可以放下滚动条（本机）闪烁，如果滚动条和框架平滑，则可以在滚动期间发出背景闪烁。

是否有标准的代码设置来处理？一种确保整个控制的顺利重绘的最佳做法 - 包括控件的非客户端区域。

例如，这里是一个裸骨控制分段更新的高度（仅重绘需要的）。如果您在表单上创建它，请尝试在其上移动一个窗口，并用颜色替换部件（请参阅paint方法）。

有没有人有类似的基础可以处理非客户区重新绘制而不闪烁的类？

 键入
 
 TMyControl = Class（TCustomControl） 
 private 
（* TWinControl：在客户端区域paint之前擦除背景）
过程WMEraseBkgnd（var Message：TWmEraseBkgnd）;消息WM_ERASEBKGND; 
受保护的
（* TCustomControl：覆盖客户端区域的绘制机制*）
过程Paint;覆盖; 
 
（* TWinControl：调整CreateWindow *的Win32参数）
过程CreateParams（var Params：TCreateParams）; override; 
 public 
构造函数Create（AOwner：TComponent）; override; 
结束; 
 
 
 {TMyControl} 
 
构造函数TMyControl.Create（AOwner：TComponent）; 
开始
继承Create（Aowner）; 
 ControlStyle：= ControlStyle  -  [csOpaque]; 
结束
 
 procedure TMyControl.CreateParams（var Params：TCreateParams）; 
 begin 
继承CreateParams（Params）; 
 
（*当一个窗口设置了此样式时，其
子窗口所占据的任何区域都将从更新区域中排除。*）
 params.ExStyle：= params.ExStyle + WS_CLIPCHILDREN; 
 
（*排除VREDRAW& HREDRAW *）
与Params.WindowClass do 
开始
（*当一个窗口类有这两个样式中的任何一个设置，
每次
都会垂直或水平（或两者）调整窗口内容将被完全重绘*）
 style：= style  -  CS_VREDRAW; 
 style：= style  -  CS_HREDRAW; 
结束
结束
 
程序TMyControl.Paint; 
 
（*内联处理：检查矩形是否为空*）
函数isEmptyRect（const aRect：TRect）：Boolean; 
开始
 result：=（arect.Right = aRect.Left）和（aRect.Bottom = aRect.Top）; 
结束
 
（*内联处理：比较两个矩形*）
函数isSameRect（const aFirstRect：TRect; const aSecondRect：TRect）：Boolean; 
开始
 result：= sysutils.CompareMem（@ aFirstRect，@ aSecondRect，SizeOf（TRect））
 end; 
 
（*内联处理：完全填写背景*）
过程FullRepaint; 
 var 
 mRect：TRect; 
开始
 mRect：= getClientRect; 
 AdjustClientRect（mRect）; 
 Canvas.Brush.Color：= clWhite; 
 Canvas.Brush.Style: =bsSolid; 
 Canvas.FillRect（mRect）; 
结束
 
 begin 
（*只有在
的情况下，才会发出完全重绘1.剪辑是空的
 2.剪辑=客户端*）
 if isEmptyRect（Canvas.ClipRect）
或isSameRect（Canvas.ClipRect，Clientrect）然后
 FullRepaint else 
开始
（*随机化颜色*）
随机化; 
 Canvas.Brush.Color：= RGB（random（255），random（255），random（255））; 
 
（*填充脏矩形*）
 Canvas.Brush.Style: =bsSolid; 
 Canvas.FillRect（canvas.ClipRect）; 
结束
结束
 
 procedure TMyControl.WMEraseBkgnd（var Message：TWmEraseBkgnd）; 
 begin 
 message.Result：=  -  1; 
结束
  

更新

我只是想补充一下，这个伎俩是如何组合的：

1. 在绘制非客户端时排除ClipRect（），所以您不要与客户端中的图形重叠



2. 捕获WMNCCalcSize消息，而不仅仅是使用borderize进行测量。我还要为边缘大小取高度：

     XEdge：= GetSystemMetrics（SM_CXEDGE）; 
    YEdge：= GetSystemMetrics（SM_CYEDGE）; 
     




3. 只要您有移动或调整大小的滚动条，调用RedrawWindow（） ：

     mRect：= ClientRect; 
    mFlags：= rdw_Invalidate 
   或RDW_NOERASE 
   或RDW_FRAME 
   或RDW_INTERNALPAINT 
   或RDW_NOCHILDREN; 
    RedrawWindow（windowhandle，@ mRect，0，mFlags）;在Paint（）方法中更新背景时，请避免绘制可能的子对象，像这样（参见上面提到的RDW_NOCHILDREN）：
     for x：= 1 to ControlCount do 
    begin 
    mCtrl：=控件[x-1]; 
   如果mCtrl.Visible然后
   开始
    mRect：= mCtrl.BoundsRect; 
    ExcludeClipRect（Canvas.Handle，
    mRect.Left，mRect.Top，
    mRect.Right，mRect.Bottom）; 
   结束
   结束
     
    




感谢您的帮助！ >


解决方案

例如，这里是一个裸骨控件，用于分段更新的高度（仅重绘需要）如果您在表单上创建它，请尝试在其上移动一个窗口，并用颜色替换部件（请参阅paint方法）。

有没有人有类似的基础可以处理非客户区重新绘制而不闪烁的类？

嗯，你的TMyControl没有一个非客户区。所以我添加了 BorderWidth：= 10; 现在已经有了。 ;）

一般来说，默认Windows窗口的非客户区域自动绘制，而不会闪烁，包括滚动条，标题等（至少我没有

如果要绘制自己的边框，则必须处理WM_NCPAINT。请参阅此代码：

  unit Unit2; 
 
接口
 
使用
类，控件，消息，Windows，SysUtils，图形; 
 
 type 
 TMyControl = class（TCustomControl）
 private 
 procedure WMEraseBkgnd（var Message：TWMEraseBkgnd）;消息WM_ERASEBKGND; 
 procedure WMNCPaint（var Message：TWMNCPaint）;消息WM_NCPAINT; 
 protected 
 procedure Paint;覆盖
程序CreateParams（var Params：TCreateParams）;覆盖
 public 
构造函数Create（AOwner：TComponent）; override; 
结束
 
实现
 
 {TMyControl} 
 
构造函数TMyControl.Create（AOwner：TComponent）; 
开始
随机化; 
继承Create（Aowner）; 
 ControlStyle：= ControlStyle  -  [csOpaque]; 
 BorderWidth：= 10; 
 Anchors：= [akLeft，akTop，akBottom，akRight]; 
结束
 
 procedure TMyControl.CreateParams（var Params：TCreateParams）; 
 begin 
继承CreateParams（Params）; 
 Params.ExStyle：= Params.ExStyle或WS_CLIPCHILDREN; 
 with Params.WindowClass do 
 style：= style and not（CS_HREDRAW或CS_VREDRAW）; 
结束
 
程序TMyControl.Paint; 
 begin 
 Canvas.Brush.Color：= RGB（随机（255），随机（255），随机（255））; 
 Canvas.FillRect（Canvas.ClipRect）; 
结束
 
程序TMyControl.WMEraseBkgnd（var Message：TWMEraseBkgnd）; 
 begin 
 Message.Result：= 1; 
结束
 
过程TMyControl.WMNCPaint（var Message：TWMNCPaint）; 
 var 
 DC：HDC; 
 R：TRect; 
 begin 
 Message.Result：= 0; 
如果BorderWidth> 0然后
 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）; 
结束
结束
结束
 
结束。 
  

几句话：

• 覆盖CreateParams而不是虚拟声明。注意编译器警告（虽然我认为/希望这有点错误）。


• 你不必检查 isEmptyRect 也不是 isSameRect 。如果 ClipRect 为空，则无法绘制。这也是为什么不直接调用Paint的原因，但总是通过Invalidate或等效的。


• 不需要AdjustClientRect。在需要时，它被内部调用。

作为一个奖励，这正是我绘制棋子组件的方式： p>

  type 
 TCustomChessBoard = class（TCustomControl）
 private 
 FBorder：TChessBoardBorder; 
 FOrientation：TBoardOrientation; 
 FSquareSize：TSquareSize; 
程序BorderChanged; 
程序RepaintBorder; 
 procedure WMEraseBkgnd（var Message：TWMEraseBkgnd）;消息WM_ERASEBKGND; 
 procedure WMNCPaint（var Message：TWMNCPaint）;消息WM_NCPAINT; 
 protected 
 procedure CreateParams（var Params：TCreateParams）;覆盖
函数GetClientRect：TRect;覆盖
程序油漆;覆盖
 procedure调整大小;覆盖
 public 
构造函数Create（AOwner：TComponent）;覆盖
程序重绘;覆盖
结束
 
 const 
 ColCount = 8; 
 RowCount = ColCount; 
 
程序TCustomChessBoard.BorderChanged; 
 begin 
 RepaintBorder; 
结束
 
构造函数TCustomChessBoard.Create（AOwner：TComponent）; 
 begin 
继承Create（AOwner）; 
 ControlStyle：= [csOpaque]; 
结束
 
程序TCustomChessBoard.CreateParams（var Params：TCreateParams）; 
 begin 
继承CreateParams（Params）; 
 with Params.WindowClass do 
 style：= style and not（CS_HREDRAW或CS_VREDRAW）; 
结束
 
函数TCustomChessBoard.GetClientRect：TRect; 
 begin 
结果：= Rect（0，0，FSquareSize * ColCount，FSquareSize * RowCount）; 
结束
 
程序TCustomChessBoard.Paint; 
 
程序DrawSquare（Col，Row：Integer）; 
 var 
 R：TRect; 
 begin 
 R：= Bounds（Col * FSquareSize，Row * FSquareSize，FSquareSize，FSquareSize）; 
 Canvas.Brush.Color：= Random（clWhite）; 
 Canvas.FillRect（R）; 
结束
 
 var 
 iCol：Integer; 
 iRow：整数; 
 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）; 
结束
 
程序TCustomChessBoard.Repaint; 
 begin 
继承Repaint; 
 RepaintBorder; 
结束
 
程序TCustomChessBoard.RepaintBorder; 
 begin 
如果Visible和HandleAllocated然后
执行（WM_NCPAINT，0，0）; 
结束
 
程序TCustomChessBoard.Resize; 
 begin 
重绘; 
继承了Resize; 
结束
 
程序TCustomChessBoard.WMEraseBkgnd（var Message：TWMEraseBkgnd）; 
 begin 
 Message.Result：= 1; 
结束
 
程序TCustomChessBoard.WMNCPaint（var Message：TWMNCPaint）; 
 var 
 DC：HDC; 
 R：TRect; 
 R2：TRect; 
 SaveFont：HFONT; 
 
程序DoCoords（ShiftX，ShiftY：Integer; Alpha，Backwards：Boolean）; 
 const 
格式= DT_CENTER或DT_NOCLIP或DT_SINGLELINE或DT_VCENTER; 
 CoordChars：Char =（（'1'，'8'），（'A'，'H'）的数组[Boolean，Boolean]）; 
 var 
 i：整数; 
 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）; 
如果向后然后
 Dec（C）
 else 
 Inc（C）; 
 OffsetRect（R，ShiftX，ShiftY）; 
 OffsetRect（R2，ShiftX，ShiftY）; 
结束
结束
 
程序DoBackground（Thickness：Integer; AColor：TColor; 
 DoPicture：Boolean）; 
 begin 
 ExcludeClipRect（DC，R.Left，R.Top，R.Right，R.Bottom）; 
 InflateRect（R，厚度，厚度）; 
如果DoPicture然后
与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）; 
结束
结束
 
 begin 
 Message.Result：= 0; 
如果BorderWidth> 0然后
与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} 
如果CanShowCoords然后
 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]）; 
 {顶部和底部} 
 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）; 
结束
结束
 finally 
 ReleaseDC（Handle，DC）; 
结束
结束
结束
  

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:

1. ExcludeClipRect() when drawing the non-clientarea, so you dont overlap with the graphics in the clientarea

2. 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);
   

3. 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);
   

4. 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!

解决方案

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;

这篇关于在Delphi中进行非闪烁，分段图形更新的最佳方法？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！