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

查看：22
本文介绍了在 Delphi 中进行非闪烁、分段图形更新的最佳方法?的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我想我可以把它扔掉然后问:我见过在图形效果方面完美无瑕的 Delphi 控件.含义:无闪烁、分段更新(仅重绘标记为脏的控件部分)和平滑滚动.

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.

这些年来我编写了很多图形控件，所以我知道双缓冲、dibs、bitblts 和所有常见"的东西(如果可能，我总是使用 dibs 来绘制所有东西，但有开销).还了解 InvalidateRect 并检查 TCanvas.ClipRect 以获取需要更新的实际矩形.尽管有所有这些典型的解决方案，但我发现很难创建与所说的相同质量的组件 - Developer Express 或 Razed Components.如果图形平滑，您可以打赌滚动条(本机)闪烁，如果滚动条和框架平滑，您可以发誓滚动期间背景闪烁.

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;

更新

我只是想补充一点，诀窍是结合了以下几点:

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

  1. 在绘制非客户区时ExcludeClipRect()，这样就不会与客户区中的图形重叠

  2. 捕获 WMNCCalcSize 消息，而不是仅使用 bordersize 进行测量.我还必须为边缘尺寸取高度:

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

  • 每当滚动条移动或调整大小时，都使用以下标志调用 RedrawWindow():

  • 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);

  • 在 Paint() 方法期间更新背景时，避免绘制可能的子对象，如下所示(参见上面提到的 RDW_NOCHILDREN):

  • 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;

    • 感谢大家的帮助！

    推荐答案

    例如，这是一个裸骨"控制分段更新的高度(仅重绘需要的部分).如果您在表单上创建它，请尝试在其上方移动一个窗口，然后观察它用颜色替换部分(参见绘制方法).

    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?

    好吧，您的 TMyControl 还没有非客户区(还没有).所以我添加了 BorderWidth := 10; 现在它有了.;)

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

    一般来说，默认 Windows 窗口的非客户区会自动绘制而不会闪烁，包括滚动条、标题等......(至少，我没有见过其他情况).

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

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

    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.

    几点说明:

    • 覆盖 CreateParams 而不是将其声明为虚拟的.注意编译器警告(尽管我认为/希望这是一个小错误).
    • 您不必检查 isEmptyRect 或 isSameRect.如果 ClipRect 为空，则没有可绘制的内容.这也是为什么从不直接调用 Paint 而是始终通过 Invalidate 或等效方法调用的原因.
    • 不需要AdjustClientRect.出于其目的而需要时会在内部调用它.
    • 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屋！

    查看全文
    相关文章
    其他开发最新文章
    热门教程
    热门工具
    登录 关闭
    扫码关注1秒登录
    发送“验证码”获取 | 15天全站免登陆