Error1024 Jan 6 2017 at 19:05

VCL, избавляемся от мерцания, раз и навсегда

34 min

44K

Tutorial

Delphi и C++Builder разработчики, использующие VCL не по наслышке знают о вездесущей проблеме мерцания контролов. Мерцание происходит при перерисовке, вследствие того, что сначала отрисовывается фон компонента, и только потом сам компонент.

И если в случае с наследниками от TWinControl частичным решением проблемы является установка свойства DoubleBuffered в True, что заставляет контрол отрисовываться в буфере (однако DoubleBuffered работает тоже не идеально, к прим.: контрол перестает быть прозрачным), то в случае с TGraphicControl решение с DoubleBuffered просто невозможно, из-за отсутствия у TGraphicControl окна, установка же DoubleBuffered в True у родителя не помогает, из-за того что отрисовка вложенных TGraphicControl-ов происходит уже после прорисовки родителя в буфере.

Обычно остается только одно — смириться с мерцанием, и максимально упростить отрисовку для минимизации эффекта, или использовать по возможности исключительно TWinControl-ы, что не всегда возможно и удобно.

Однажды намучившись с мерцанием, я не выдержал и решил решить эту проблему, раз и навсегда!

Как мне удалось решить проблему?

Заранее извиняюсь за некоторую сумбурность подачи, и недосказанность, описывать подобные вещи довольно сложно, однако поделиться с сообществом хочется.

Был разработан класс TEsCustomControl = class(TWinControl), который осуществляет альтернативную буферизацию (при DoubleBuffered = False, иначе используется родная буферизация VCL).

Класс имеет свойство BufferedChildren, при активации которого отрисовка вложенных TGraphicControl-ов происходит в буфере, что полностью избавляет от мерцания.

К счастью в VCL нужные методы отрисовки объявлены не как private, что и позволило реализовать полную буферизацию.

Для того чтобы компонент выглядел прозрачным, необходимо отрисовать на нем фон нижележащего компонента, что осуществляется с помощью процедуры DrawParentImage.

procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);
var
  ClientRect: TRect;
  P: TPoint;
  SaveIndex: Integer;
begin
  if Control.Parent = nil then
    Exit;
  SaveIndex := SaveDC(DC);
  GetViewportOrgEx(DC, P);

  // if control has non client border then need additional offset viewport
  ClientRect := Control.ClientRect;
  if (ClientRect.Right <> Control.Width) or (ClientRect.Bottom <> Control.Height) then
  begin
    ClientRect := CalcClientRect(Control);
    SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil);
  end else
    SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil);

  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);

  Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
  Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT);

  RestoreDC(DC, SaveIndex);

  if InvalidateParent then
    if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and
       not (csDesigning in Control.ComponentState)and not (Control.Parent is TEsCustomControl) then
    begin
      Control.Parent.Invalidate;
    end;

  SetViewportOrgEx(DC, P.X, P.Y, nil);
end;

Буферизация происходит за счет того что компонент в переопределенном методе PaintWindow отрисовывается не непосредственно на предоставленный хендл, а на временный (или нет в зависимости от свойства IsCachedBuffer) HBITMAP, и уже после полной отрисовки копируется функцией BitBlt.

(Довольно много кода, из-за многих частных случаев)

TEsCustomControl.PaintWindow

procedure TEsCustomControl.PaintWindow(DC: HDC);
var
  TempDC: HDC;
  UpdateRect: TRect;
  //---
  BufferDC: HDC;
  BufferBitMap: HBITMAP;
  Region: HRGN;
  SaveViewport: TPoint;
  BufferedThis: Boolean;
begin
  BufferBitMap := 0;
  Region := 0;
  BufferDC := 0;

  if GetClipBox(DC, UpdateRect) = ERROR then
    UpdateRect := ClientRect;

  BufferedThis := not BufferedChildren;

  // fix for designer selection
  BufferedThis := BufferedThis or (csDesigning in ComponentState);

  try
    if BufferedThis then
    begin
    //------------------------------------------------------------------------------------------------
    // Duplicate code, see PaintHandler, Please sync this code!!!
    //------------------------------------------------------------------------------------------------
      // if control not double buffered then create or assign buffer
      if not DoubleBuffered then
      begin
        BufferDC := CreateCompatibleDC(DC);
        // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
        // return <> 0 => need to double buffer || return = 0 => no need to double buffer
        if BufferDC <> 0 then
        begin
          // Using the cache if possible
          if FIsCachedBuffer or FIsFullSizeBuffer then
          begin
            // Create cache if need
            if CacheBitmap = 0 then
            begin
              BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
              // Assign to cache if need
              if FIsCachedBuffer then
                CacheBitmap := BufferBitMap;
            end
            else
              BufferBitMap := CacheBitmap;

            // Assign region for minimal overdraw
            Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
            SelectClipRgn(BufferDC, Region);
          end
          else
            // Create buffer
            BufferBitMap := CreateCompatibleBitmap(DC, RectWidth(UpdateRect), RectHeight(UpdateRect));
          // Select buffer bitmap
          SelectObject(BufferDC, BufferBitMap);
          // [change coord], if need
          // Moving update region to the (0,0) point
          if not(FIsCachedBuffer or FIsFullSizeBuffer) then
          begin
            GetViewportOrgEx(BufferDC, SaveViewport);
            SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
          end;
        end
        else
          BufferDC := DC;
      end
      else
        BufferDC := DC;
    //------------------------------------------------------------------------------------------------
    end else
      BufferDC := DC;

    if not(csOpaque in ControlStyle) then
      if ParentBackground then
      begin
        if FIsCachedBackground then
        begin
          if CacheBackground = 0 then
          begin
            TempDC := CreateCompatibleDC(DC);
            CacheBackground := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
            SelectObject(TempDC, CacheBackground);
            DrawBackground(TempDC); //DrawParentImage(Self, TempDC, False);
            DeleteDC(TempDC);
          end;
          TempDC := CreateCompatibleDC(BufferDC);
          SelectObject(TempDC, CacheBackground);
          if not FIsCachedBuffer then
            BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY)
          else
            BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          DeleteDC(TempDC);
        end
        else
          DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False);
      end else
        if (not DoubleBuffered or (DC <> 0)) then
          if not IsStyledClientControl(Self) then
            FillRect(BufferDC, ClientRect, Brush.Handle)
          else
          begin
            SetDCBrushColor(BufferDC,
              ColorToRGB({$ifdef VER230UP}StyleServices.GetSystemColor(Color){$else}Color{$endif}));
            FillRect(BufferDC, ClientRect, GetStockObject(DC_BRUSH));
          end;

    FCanvas.Lock;
    try
      Canvas.Handle := BufferDC;
      TControlCanvas(Canvas).UpdateTextFlags;

      if Assigned(FOnPainting) then
        FOnPainting(Self, Canvas, ClientRect);
      Paint;
      if Assigned(FOnPaint) then
        FOnPaint(Self, Canvas, ClientRect);
    finally
      FCanvas.Handle := 0;
      FCanvas.Unlock;
    end;

  finally
    if BufferedThis then
    begin
      //------------------------------------------------------------------------------------------------
      // Duplicate code, see PaintHandler, Please sync this code!!!
      //------------------------------------------------------------------------------------------------
      try
        // draw to window
        if not DoubleBuffered then
        begin
          if not(FIsCachedBuffer or FIsFullSizeBuffer) then
          begin
            // [restore coord], if need
            SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
          end
          else
          begin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finally
        if BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0 then
          DeleteObject(Region);
        // delete buffer, if need
        if not FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------
    end;
  end;
end;

Буферизация вложенных TGraphicControl-ов реализована альтернативным методом PaintHandler, в котором происходит буферизация всех этапов прорисовки компонента, в том числе и отрисовки TGraphicControl-ов.

TEsCustomControl.PaintHandler

procedure TEsCustomControl.WMPaint(var Message: TWMPaint);
begin
  ControlState := ControlState + [csCustomPaint];

  // buffered childen aviable only for not DoubleBuffered controls
  if BufferedChildren and (not FDoubleBuffered) and
     not (csDesigning in ComponentState) then // fix for designer selection
  begin
    PaintHandler(Message)// My new PaintHandler
  end else
    inherited;

  ControlState := ControlState - [csCustomPaint];
end;

procedure TEsCustomControl.PaintHandler(var Message: TWMPaint);
var
  PS: TPaintStruct;
  BufferDC: HDC;
  BufferBitMap: HBITMAP;
  UpdateRect: TRect;
  SaveViewport: TPoint;
  Region: HRGN;
  DC: HDC;
  IsBeginPaint: Boolean;
begin
  BufferBitMap := 0;
  BufferDC := 0;
  DC := 0;
  Region := 0;
  IsBeginPaint := Message.DC = 0;

  try
    if IsBeginPaint then
    begin
      DC := BeginPaint(Handle, PS);
      {$IFDEF VER230UP}
      if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
        UpdateRect := ClientRect
        // I had to use a crutch to ClientRect, due to the fact that
        // VCL.Styles.TCustomStyle.DoDrawParentBackground NOT use relative coordinates,
        // ie ignores SetViewportOrgEx!
        // This function uses ClientToScreen and ScreenToClient for coordinates calculation!
      else
      {$endif}
        UpdateRect := PS.rcPaint;
    end
    else
    begin
      DC := Message.DC;
      {$IFDEF VER230UP}
      if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
        UpdateRect := ClientRect
      else
      {$endif}
        if GetClipBox(DC, UpdateRect) = ERROR then
          UpdateRect := ClientRect;
    end;

    //------------------------------------------------------------------------------------------------
    // Duplicate code, see PaintWindow, Please sync this code!!!
    //------------------------------------------------------------------------------------------------
    // if control not double buffered then create or assign buffer
    if not DoubleBuffered then
    begin
      BufferDC := CreateCompatibleDC(DC);
      // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
      // return <> 0 => need to double buffer || return = 0 => no need to double buffer
      if BufferDC <> 0 then
      begin
        // Using the cache if possible
        if FIsCachedBuffer or FIsFullSizeBuffer then
        begin
          // Create cache if need
          if CacheBitmap = 0 then
          begin
            BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
            // Assign to cache if need
            if FIsCachedBuffer then
              CacheBitmap := BufferBitMap;
          end
          else
            BufferBitMap := CacheBitmap;

          // Assign region for minimal overdraw
          Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
          SelectClipRgn(BufferDC, Region);
        end
        else
          // Create buffer
          BufferBitMap := CreateCompatibleBitmap(DC,
            UpdateRect.Right - UpdateRect.Left, UpdateRect.Bottom - UpdateRect.Top);
        // Select buffer bitmap
        SelectObject(BufferDC, BufferBitMap);
        // [change coord], if need
        // Moving update region to the (0,0) point
        if not(FIsCachedBuffer or FIsFullSizeBuffer) then
        begin
          GetViewportOrgEx(BufferDC, SaveViewport);
          SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
        end;
      end
      else
        BufferDC := DC;
    end
    else
      BufferDC := DC;
    //------------------------------------------------------------------------------------------------

    // DEFAULT HANDLER:
    Message.DC := BufferDC;
    inherited PaintHandler(Message);

  finally
    try
      //------------------------------------------------------------------------------------------------
      // Duplicate code, see PaintWindow, Please sync this code!!!
      //------------------------------------------------------------------------------------------------
      try
        // draw to window
        if not DoubleBuffered then
        begin
          if not(FIsCachedBuffer or FIsFullSizeBuffer) then
          begin
            // [restore coord], if need
            SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
          end
          else
          begin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finally
        if BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0 then
          DeleteObject(Region);
        // delete buffer, if need
        if not FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------
    finally
      // end paint, if need
      if IsBeginPaint then
        EndPaint(Handle, PS);
    end;
  end;
end;

Класс TEsCustomControl имеет несколько полезных свойств и событий:

  TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect) of object;

  /// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary>
  TEsCustomControl = class(TWinControl)
  ...
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateBackground(Repaint: Boolean); overload;
    procedure UpdateBackground; overload;
    // ------------------ Properties for published -------------------------------------------------
    property DoubleBuffered default False;
    {$IFDEF VER210UP}
    property ParentDoubleBuffered default False;
    {$ENDIF}
    // Painting for chidrens classes
    property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
    property OnPainting: TPaintEvent read FOnPainting write FOnPainting;
    // BufferedChildrens
    property ParentBufferedChildren: Boolean read FParentBufferedChildren write SetParentBufferedChildren default True;
    property BufferedChildren: Boolean read FBufferedChildren write SetBufferedChildren stored IsBufferedChildrenStored;
    // External prop
    property IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False;
    property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False;
    property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
    property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False;
    property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write SetIsFullSizeBuffer default False;
  end;

Интересным может оказаться свойство IsDrawHelper рисующее удобную рамку в DesignTime.

Для создания своего не мерцающего компонента вам достаточно унаследоваться от TEsCustomControl, как если бы вы делали наследника от TCustomControl, и объявить нужные вам свойства как published.

TEsCustomControl дает полное управление процессом буферизации и отрисовки, и доказал свою надежность во многих проектах и компонентах.

Для примера можно рассмотреть компонент TEsLayout — прозрачный Layout с возможностью буферизации вложенных в него TGraphicControl-ов:
https://github.com/errorcalc/FreeEsVclComponents/blob/master/Source/ES.Layouts.pas

И под спойлером

{******************************************************************************}
{                            EsVclComponents v2.0                              }
{                           ErrorSoft(c) 2009-2016                             }
{                                                                              }
{                     More beautiful things: errorsoft.org                     }
{                                                                              }
{           errorsoft@mail.ru | vk.com/errorsoft | github.com/errorcalc        }
{              errorsoft@protonmail.ch | habrahabr.ru/user/error1024           }
{                                                                              }
{         Open this on github: github.com/errorcalc/FreeEsVclComponents        }
{                                                                              }
{ You can order developing vcl/fmx components, please submit requests to mail. }
{ Вы можете заказать разработку VCL/FMX компонента на заказ.                   }
{******************************************************************************}
unit ES.Layouts;

interface

uses
  Winapi.Messages, Vcl.Controls, System.Classes, System.Types, Vcl.Graphics, ES.BaseControls,
  ES.CfxClasses;

type
  TEsCustomLayout = class(TEsBaseLayout)
  private
    FLocked: Boolean;
    procedure CMIsToolControl(var Message: TMessage); message CM_ISTOOLCONTROL;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    property UseDockManager default True;
  public
    constructor Create(AOwner: TComponent); override;
    property Color default clBtnFace;
    property DockManager;
    property Locked: Boolean read FLocked write FLocked default False;
  end;

  TEsLayout = class(TEsCustomLayout)
  published
    property Align;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property BorderWidth;
    property BufferedChildren;// TEsCustomControl
    property Color;
    property Constraints;
    property Ctl3D;
    property UseDockManager;
    property DockSite;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property IsCachedBuffer;// TEsCustomControl
    property IsCachedBackground;// TEsCustomControl
    property IsDrawHelper;// TEsCustomControl
    property IsOpaque;// TEsCustomControl
    property IsFullSizeBuffer;// TEsCustomControl
    property Locked;
    property Padding;
    property ParentBiDiMode;
    property ParentBackground;
    property ParentBufferedChildren;// TEsCustomControl
    property ParentColor;
    property ParentCtl3D;
    property ParentDoubleBuffered;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Touch;
    property Visible;
    {$if CompilerVersion > 23}
    property StyleElements;
    {$ifend}
    property OnAlignInsertBefore;
    property OnAlignPosition;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDockDrop;
    property OnDockOver;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGesture;
    property OnGetSiteInfo;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnPaint;// TEsCustomControl
    property OnPainting;// TEsCustomControl
    property OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;

  TEsPanel = class(TEsLayout)
  private
    FFrameWidth: TFrameWidth;
    FFrameColor: TColor;
    FFrameStyle: TFrameStyle;
    procedure SetFrameColor(const Value: TColor);
    procedure SetFrameStyle(const Value: TFrameStyle);
    procedure SetFrameWidth(const Value: TFrameWidth);
  protected
    procedure Paint; override;
    procedure AdjustClientRect(var Rect: TRect); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property BevelKind;
    property BevelInner;
    property BevelOuter;
    property FrameStyle: TFrameStyle read FFrameStyle write SetFrameStyle default TExFrameStyle.Raised;
    property FrameColor: TColor read FFrameColor write SetFrameColor default clBtnShadow;
    property FrameWidth: TFrameWidth read FFrameWidth write SetFrameWidth default 1;
  end;

implementation

uses
  ES.ExGraphics, ES.Utils, Vcl.Themes;

procedure TEsCustomLayout.CMIsToolControl(var Message: TMessage);
begin
  if not FLocked then Message.Result := 1;
end;

constructor TEsCustomLayout.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csSetCaption, csParentBackground, csDoubleClicks, csReplicatable, csPannable, csGestures];
  Width := 185;
  Height := 41;
  UseDockManager := True;
end;

procedure TEsCustomLayout.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  // nope now
end;

{ TEsPanel }

procedure TEsPanel.AdjustClientRect(var Rect: TRect);
begin
  inherited;
  if FrameStyle <> TExFrameStyle.None then
  begin
    Rect.Inflate(-GetFrameWidth(FrameStyle, FrameWidth), -GetFrameWidth(FrameStyle, FrameWidth));
  end;
end;

constructor TEsPanel.Create(AOwner: TComponent);
begin
  inherited;

  FFrameColor := clBtnShadow;
  FFrameWidth := 1;
  FFrameStyle := TExFrameStyle.Raised;
end;

procedure TEsPanel.Paint;
begin
  if (csDesigning in ComponentState) and IsDrawHelper then
    DrawControlHelper(Self, [hoPadding, hoClientRect], GetFrameWidth(FrameStyle, FrameWidth));

  if FrameStyle <> TExFrameStyle.None then
    if IsStyledBorderControl(Self) then
      DrawFrame(Canvas, ClientRect, FrameStyle, FrameWidth, StyleServices.GetSystemColor(FrameColor),
        StyleServices.GetSystemColor(clBtnHighlight), StyleServices.GetSystemColor(clBtnShadow))
    else
      DrawFrame(Canvas, ClientRect, FrameStyle, FrameWidth, FrameColor, clBtnHighlight, clBtnShadow);

end;

procedure TEsPanel.SetFrameColor(const Value: TColor);
begin
  if FFrameColor <> Value then
  begin
    FFrameColor := Value;
    Invalidate;
  end;
end;

procedure TEsPanel.SetFrameStyle(const Value: TFrameStyle);
begin
  if FFrameStyle <> Value then
  begin
    FFrameStyle := Value;
    Realign;
    Invalidate;
  end;
end;

procedure TEsPanel.SetFrameWidth(const Value: TFrameWidth);
begin
  if FFrameWidth <> Value then
  begin
    FFrameWidth := Value;
    Realign;
    Invalidate;
  end;
end;

end.

Исходный же код модуля содержащего TEsCustomControl и его версии-Layout-а TEsBaseLayout доступен по ссылке:
https://github.com/errorcalc/FreeEsVclComponents/blob/master/Source/ES.BaseControls.pas

И под спойлером

{******************************************************************************}
{                       EsVclComponents/EsVclCore v3.0                         }
{                           errorsoft(c) 2009-2018                             }
{                                                                              }
{                     More beautiful things: errorsoft.org                     }
{                                                                              }
{           errorsoft@mail.ru | vk.com/errorsoft | github.com/errorcalc        }
{              errorsoft@protonmail.ch | habrahabr.ru/user/error1024           }
{                                                                              }
{         Open this on github: github.com/errorcalc/FreeEsVclComponents        }
{                                                                              }
{ You can order developing vcl/fmx components, please submit requests to mail. }
{ �� ������ �������� ���������� VCL/FMX ���������� �� �����.                   }
{******************************************************************************}

{
  This is the base unit, which must remain Delphi 7 support, and it should not
  be dependent on any other units!
}

unit ES.BaseControls;

{$IF CompilerVersion >= 18} {$DEFINE VER180UP} {$IFEND}
{$IF CompilerVersion >= 21} {$DEFINE VER210UP} {$IFEND}
{$IF CompilerVersion >= 23} {$DEFINE VER230UP} {$IFEND}
{$IF CompilerVersion >= 24} {$DEFINE VER240UP} {$IFEND}

// see function CalcClientRect
{$define FAST_CALC_CLIENTRECT}

// see TEsBaseLayout.ContentRect
{$define TEST_CONTROL_CONTENT_RECT}

interface

uses
  WinApi.Windows, System.Types, System.Classes, Vcl.Controls,
  Vcl.Graphics, {$IFDEF VER230UP}Vcl.Themes,{$ENDIF} WinApi.Messages, WinApi.Uxtheme, Vcl.Forms;

const
  CM_ESBASE = CM_BASE + $0800;
  CM_PARENT_BUFFEREDCHILDRENS_CHANGED = CM_ESBASE + 1;

  EsVclCoreVersion = 3.0;

type
  THelperOption = (hoPadding, hoBorder, hoClientRect);
  THelperOptions = set of THelperOption;

  TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect) of object;

  /// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary>
  TEsCustomControl = class(TWinControl)
  private
    // anti flicker and transparent magic
    FCanvas: TCanvas;
    CacheBitmap: HBITMAP;// Cache for buffer BitMap
    CacheBackground: HBITMAP;// Cache for background BitMap
    FIsCachedBuffer: Boolean;
    FIsCachedBackground: Boolean;
    FBufferedChildren: Boolean;
    FParentBufferedChildren: Boolean;
    FIsFullSizeBuffer: Boolean;
    // paint events
    FOnPaint: TPaintEvent;
    FOnPainting: TPaintEvent;
    // draw helper
    FIsDrawHelper: Boolean;
    // paint
    procedure SetIsCachedBuffer(Value: Boolean);
    procedure SetIsCachedBackground(Value: Boolean);
    procedure SetIsDrawHelper(const Value: Boolean);
    procedure SetIsOpaque(const Value: Boolean);
    function GetIsOpaque: Boolean;
    procedure SetBufferedChildren(const Value: Boolean);
    procedure SetParentBufferedChildren(const Value: Boolean);
    function GetTransparent: Boolean;
    procedure SetTransparent(const Value: Boolean);
    function IsBufferedChildrenStored: Boolean;
    // handle messages
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMParentBufferedChildrensChanged(var Message: TMessage); message CM_PARENT_BUFFEREDCHILDRENS_CHANGED;
    procedure DrawBackgroundForOpaqueControls(DC: HDC);
    // intercept mouse
    // procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    // other
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure WMTextChanges(var Message: TMessage); message WM_SETTEXT;
    // fix
    procedure FixBufferedChildren(Reader: TReader);
    procedure FixParentBufferedChildren(Reader: TReader);
    procedure SetIsFullSizeBuffer(const Value: Boolean);
  protected
    // fix
    procedure DefineProperties(Filer: TFiler); override;
    // paint
    property Canvas: TCanvas read FCanvas;
    procedure DeleteCache;{$IFDEF VER210UP}inline;{$ENDIF}
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    procedure PaintHandler(var Message: TWMPaint);
    procedure DrawBackground(DC: HDC); virtual;
    // other
    procedure UpdateText; dynamic;
    //
    property ParentBackground default True;
    property Transparent: Boolean read GetTransparent write SetTransparent default True;// analog of ParentBackground
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateBackground(Repaint: Boolean); overload;
    procedure UpdateBackground; overload;
    // ------------------ Properties for published -------------------------------------------------
    property DoubleBuffered default False;
    {$IFDEF VER210UP}
    property ParentDoubleBuffered default False;
    {$ENDIF}
    // Painting for chidrens classes
    property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
    property OnPainting: TPaintEvent read FOnPainting write FOnPainting;
    // BufferedChildrens
    property ParentBufferedChildren: Boolean read FParentBufferedChildren write SetParentBufferedChildren default True;
    property BufferedChildren: Boolean read FBufferedChildren write SetBufferedChildren stored IsBufferedChildrenStored;
    // External prop
    property IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False;
    property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False;
    property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
    property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False;
    property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write SetIsFullSizeBuffer default False;
  end;

  {$IFDEF VER180UP}
  TContentMargins = record
  type
    TMarginSize = 0..MaxInt;
  private
    Left: TMarginSize;
    Top: TMarginSize;
    Right: TMarginSize;
    Bottom: TMarginSize;
  public
    function Width: TMarginSize;
    function Height: TMarginSize;
    procedure Inflate(DX, DY: Integer); overload;
    procedure Inflate(DLeft, DTop, DRight, DBottom: Integer); overload;
    procedure Reset;
    constructor Create(Left, Top, Right, Bottom: TMarginSize); overload;
  end;

  /// <summary> ONLY INTERNAL USE! THIS CLASS CAN BE DELETED! (USE TEsCustomControl OR TEsCustomLayot) </summary>
  TEsBaseLayout = class(TEsCustomControl)
  private
    FBorderWidth: TBorderWidth;
    procedure SetBorderWidth(const Value: TBorderWidth);
  protected
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    procedure AdjustClientRect(var Rect: TRect); override;
    procedure Paint; override;
    // new
    procedure CalcContentMargins(var Margins: TContentMargins); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    function ContentRect: TRect; virtual;
    function ContentMargins: TContentMargins; inline;
    property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0;
    property BufferedChildren default True;
  end;

  /// <summary> The GraphicControl, supports Padding and IsDrawHelper property </summary>
  TEsGraphicControl = class(TGraphicControl)
  private
    FPadding: TPadding;
    FIsDrawHelper: Boolean;
    function GetPadding: TPadding;
    procedure SetPadding(const Value: TPadding);
    procedure PaddingChange(Sender: TObject);
    procedure SetIsDrawHelper(const Value: Boolean);
  protected
    procedure Paint; override;
    function HasPadding: Boolean;
    // new
    procedure CalcContentMargins(var Margins: TContentMargins); virtual;
  public
    destructor Destroy; override;
    property Padding: TPadding read GetPadding write SetPadding;
    function ContentRect: TRect; virtual;
    function ContentMargins: TContentMargins; inline;
    property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
  end;

  procedure DrawControlHelper(Control: TControl; Options: THelperOptions; FrameWidth: Integer = 0); overload;
  procedure DrawControlHelper(Canvas: TCanvas; Rect: TRect; BorderWidth: TBorderWidth;
    Padding: TPadding; Options: THelperOptions); overload;
  {$ENDIF}

  function CalcClientRect(Control: TControl): TRect;

  procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);

implementation

uses
  System.SysUtils, System.TypInfo;

type
  TOpenCtrl = class(TWinControl)
  public
    property BorderWidth;
  end;

// Old delphi support
{$IFNDEF VER210UP}
function RectWidth(const Rect: TRect): Integer;
begin
  Result := Rect.Right - Rect.Left;
end;

function RectHeight(const Rect: TRect): Integer;
begin
  Result := Rect.Bottom - Rect.Top;
end;
{$ENDIF}

{$IFDEF VER210UP} {$REGION 'DrawControlHelper'}
procedure DrawControlHelper(Canvas: TCanvas; Rect: TRect; BorderWidth: TBorderWidth;
  Padding: TPadding; Options: THelperOptions);
  procedure Line(Canvas: TCanvas; x1, y1, x2, y2: Integer);
  begin
    Canvas.MoveTo(x1, y1);
    Canvas.LineTo(x2, y2);
  end;
var
  SaveBk: TColor;
  SavePen, SaveBrush: TPersistent;
begin
  SavePen := nil;
  SaveBrush := nil;

  try
    if Canvas.Handle = 0 then
      Exit;

    // save canvas state
    SavePen := TPen.Create;
    SavePen.Assign(Canvas.Pen);
    SaveBrush := TBrush.Create;
    SaveBrush.Assign(Canvas.Brush);

    Canvas.Pen.Mode := pmNot;
    Canvas.Pen.Style := psDash;
    Canvas.Brush.Style := bsClear;

    // ClientRect Helper
    if THelperOption.hoClientRect in Options then
    begin
      SaveBk := SetBkColor(Canvas.Handle, RGB(127,255,255));
      DrawFocusRect(Canvas.Handle, Rect);
      SetBkColor(Canvas.Handle, SaveBk);
    end;

    // Border Helper
    if THelperOption.hoBorder in Options then
    begin
      if (BorderWidth <> 0) and (BorderWidth * 2 <= RectWidth(Rect)) and (BorderWidth * 2 <= RectHeight(Rect)) then
        Canvas.Rectangle(Rect.Left + BorderWidth, Rect.Top + BorderWidth,
          Rect.Right - BorderWidth, Rect.Bottom - BorderWidth);
    end;

    // Padding Helper
    if THelperOption.hoPadding in Options then
    begin
      if (BorderWidth + Padding.Top < RectHeight(Rect) - BorderWidth - Padding.Bottom) and
         (BorderWidth + Padding.Left < RectWidth(Rect) - BorderWidth - Padding.Right) then
      begin
        Canvas.Pen.Style := psDot;

        if Padding.Left <> 0 then
          Line(Canvas, Rect.Left + Padding.Left + BorderWidth, Rect.Top + Padding.Top + BorderWidth,
            Rect.Left + Padding.Left + BorderWidth, Rect.Bottom - Padding.Bottom - BorderWidth - 1);
        if Padding.Top <> 0 then
          Line(Canvas, Rect.Left + Padding.Left + BorderWidth, Rect.Top + Padding.Top + BorderWidth,
            Rect.Right - Padding.Right - BorderWidth - 1, Rect.Top + Padding.Top + BorderWidth);
        if Padding.Right <> 0 then
          Line(Canvas, Rect.Right - Padding.Right - BorderWidth - 1, Rect.Top + Padding.Top + BorderWidth,
            Rect.Right - Padding.Right - BorderWidth - 1, Rect.Bottom - Padding.Bottom - BorderWidth - 1);
        if Padding.Bottom <> 0 then
          Line(Canvas, Rect.Left + Padding.Left + BorderWidth, Rect.Bottom - Padding.Bottom - BorderWidth - 1,
            Rect.Right - Padding.Right - BorderWidth - 1, Rect.Bottom - Padding.Bottom - BorderWidth - 1);
      end;
    end;

    Canvas.Pen.Assign(SavePen);
    Canvas.Brush.Assign(SaveBrush);
  finally
    SavePen.Free;
    SaveBrush.Free;
  end;
end;

procedure DrawControlHelper(Control: TControl; Options: THelperOptions; FrameWidth: Integer = 0);
var
  Canvas: TCanvas;
  Padding: TPadding;
  BorderWidth: Integer;
  MyCanvas: Boolean;
  R: TRect;
begin
  MyCanvas := False;
  Canvas := nil;
  Padding := nil;
  BorderWidth := 0;

  // if win control
  if Control is TWinControl then
  begin
    TOpenCtrl(Control).AdjustClientRect(R);

    // get padding
    Padding := TWinControl(Control).Padding;
    // get canvas
    if Control is TEsCustomControl then
      Canvas := TEsCustomControl(Control).Canvas
    else
    begin
      MyCanvas := True;
      Canvas := TControlCanvas.Create;
      TControlCanvas(Canvas).Control := Control;
    end;
    // get border width
    if Control is TEsBaseLayout then
      BorderWidth := TEsBaseLayout(Control).BorderWidth
    else
      BorderWidth := TOpenCtrl(Control).BorderWidth;
  end else
  if Control is TGraphicControl then
  begin
    // get canvas
    Canvas := TEsGraphicControl(Control).Canvas;
    if Control is TEsGraphicControl then
      Padding := TEsGraphicControl(Control).Padding;
  end;

  try
    R := Control.ClientRect;
    R.Inflate(-FrameWidth, -FrameWidth);
    DrawControlHelper(Canvas, R, BorderWidth, Padding, Options);
  finally
    if MyCanvas then
      Canvas.Free;
  end;
end;
{$ENDREGION} {$ENDIF}

function IsStyledClientControl(Control: TControl): Boolean;
begin
  Result := False;

  {$IFDEF VER230UP}
  if Control = nil then
    Exit;

  if StyleServices.Enabled then
  begin
    Result := {$ifdef VER240UP}(seClient in Control.StyleElements) and{$endif}
      TStyleManager.IsCustomStyleActive;
  end;
  {$ENDIF}
end;

function CalcClientRect(Control: TControl): TRect;
var
  {$ifdef FAST_CALC_CLIENTRECT}
  Info: TWindowInfo;
  {$endif}
  IsFast: Boolean;
begin
  {$ifdef FAST_CALC_CLIENTRECT}
  IsFast := True;
  {$else}
  IsFast := False;
  {$endif}

  Result := Rect(0, 0, Control.Width, Control.Height);

  // Only TWinControl's has non client area
  if not (Control is TWinControl) then
    Exit;

  // Fast method not work for controls not having Handle
  if not TWinControl(Control).Handle <> 0 then
    IsFast := False;

  if IsFast then
  begin
    ZeroMemory(@Info, SizeOf(TWindowInfo));
    Info.cbSize := SizeOf(TWindowInfo);
    GetWindowInfo(TWinControl(Control).Handle, info);
    Result.Left := Info.rcClient.Left - Info.rcWindow.Left;
    Result.Top := Info.rcClient.Top - Info.rcWindow.Top;
    Result.Right := -Info.rcWindow.Left + Info.rcClient.Right;
    Result.Top := -Info.rcWindow.Top + Info.rcClient.Bottom;
  end else
  begin
    Control.Perform(WM_NCCALCSIZE, 0, LParam(@Result));
  end;
end;

procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);
var
  ClientRect: TRect;
  P: TPoint;
  SaveIndex: Integer;
begin
  if Control.Parent = nil then
    Exit;
  SaveIndex := SaveDC(DC);
  GetViewportOrgEx(DC, P);

  // if control has non client border then need additional offset viewport
  ClientRect := Control.ClientRect;
  if (ClientRect.Right <> Control.Width) or (ClientRect.Bottom <> Control.Height) then
  begin
    ClientRect := CalcClientRect(Control);
    SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil);
  end else
    SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil);

  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);

  Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
  Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT);

  RestoreDC(DC, SaveIndex);

  if InvalidateParent then
    if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and
       not (csDesigning in Control.ComponentState)and not (Control.Parent is TEsCustomControl) then
    begin
      Control.Parent.Invalidate;
    end;

  SetViewportOrgEx(DC, P.X, P.Y, nil);
end;

procedure BitmapDeleteAndNil(var Bitmap: HBITMAP);{$IFDEF VER210UP}inline;{$ENDIF}
begin
  if Bitmap <> 0 then
  begin
    DeleteObject(Bitmap);
    Bitmap := 0;
  end;
end;

procedure TEsCustomControl.CMParentBufferedChildrensChanged(var Message: TMessage);
begin
  if FParentBufferedChildren then
  begin
    if Parent <> nil then
    begin
      if Parent is TEsCustomControl then
        BufferedChildren := TEsCustomControl(Parent).BufferedChildren
      else
        BufferedChildren := False;
    end;
    FParentBufferedChildren := True;
  end;
end;

procedure TEsCustomControl.CMTextChanged(var Message: TMessage);
begin
  inherited;
  UpdateText;
end;

procedure TEsCustomControl.WMTextChanges(var Message: TMessage);
begin
  Inherited;
  UpdateText;
end;

constructor TEsCustomControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  // init
  ControlStyle := ControlStyle - [csOpaque] + [csParentBackground];
  {$IFDEF VER210UP}
  ParentDoubleBuffered := False;
  {$ENDIF}

  CacheBitmap := 0;
  CacheBackground := 0;

  // canvas
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;

  // new props
  FParentBufferedChildren := True;
  FBufferedChildren := False;
  FIsCachedBuffer := False;
  FIsCachedBackground := False;
  FIsFullSizeBuffer := False;
  FIsDrawHelper := False;
end;

// temp fix
procedure TEsCustomControl.DefineProperties(Filer: TFiler);
begin
  inherited;
  Filer.DefineProperty('BufferedChildrens', FixBufferedChildren, nil, False);
  Filer.DefineProperty('ParentBufferedChildrens', FixParentBufferedChildren, nil, False);
end;

// ok
procedure TEsCustomControl.DeleteCache;
begin
  BitmapDeleteAndNil(CacheBitmap);
  BitmapDeleteAndNil(CacheBackground);
end;

destructor TEsCustomControl.Destroy;
begin
  FCanvas.Free;
  DeleteCache;
  inherited;
end;

procedure TEsCustomControl.DrawBackground(DC: HDC);
begin
  DrawParentImage(Self, DC, False);
end;

// hack for bad graphic controls
procedure TEsCustomControl.DrawBackgroundForOpaqueControls(DC: HDC);
var
  i: integer;
  Control: TControl;
  Prop: Pointer;
begin
  for i := 0 to ControlCount - 1 do
  begin
    Control := Controls[i];
    if (Control is TGraphicControl) and (csOpaque in Control.ControlStyle) and Control.Visible and
       (not (csDesigning in ComponentState) or not (csNoDesignVisible in ControlStyle)
       {$IFDEF VER210UP}or not (csDesignerHide in Control.ControlState){$ENDIF})
    then
    begin
      // Necessary to draw a background if the control has a Property 'Transparent' and hasn't a Property 'Color'
      Prop := GetPropInfo(Control.ClassInfo, 'Transparent');
      if Prop <> nil then
      begin
        Prop := GetPropInfo(Control.ClassInfo, 'Color');
        if Prop = nil then
          FillRect(DC, Rect(Control.Left, Control.Top, Control.Left + Control.Width, Control.Top + Control.Height), Brush.Handle);
      end;
    end;
  end;
end;

(*procedure TEsCustomControl.EndCachedBackground;
begin
  FIsCachedBackground := StoredCachedBackground;
end;

procedure TEsCustomControl.EndCachedBuffer;
begin
  FIsCachedBuffer := StoredCachedBuffer;
end;*)

// temp fix
procedure TEsCustomControl.FixBufferedChildren(Reader: TReader);
begin
  BufferedChildren := Reader.ReadBoolean;
end;

// temp fix
procedure TEsCustomControl.FixParentBufferedChildren(Reader: TReader);
begin
  ParentBufferedChildren := Reader.ReadBoolean;
end;

function TEsCustomControl.GetIsOpaque: Boolean;
begin
  Result := csOpaque in ControlStyle;
end;

function TEsCustomControl.GetTransparent: Boolean;
begin
  Result := ParentBackground;
end;

procedure TEsCustomControl.Paint;
var
  SaveBk: TColor;
begin
  // for Design time
  if IsDrawHelper and(csDesigning in ComponentState) then
  begin
    SaveBk := SetBkColor(Canvas.Handle, RGB(127,255,255));
    DrawFocusRect(Canvas.Handle, Self.ClientRect);
    SetBkColor(Canvas.Handle, SaveBk);
  end;
end;

{ TODO -cCRITICAL : 22.02.2013:
  eliminate duplication of code! }
procedure TEsCustomControl.PaintHandler(var Message: TWMPaint);
var
  PS: TPaintStruct;
  BufferDC: HDC;
  BufferBitMap: HBITMAP;
  UpdateRect: TRect;
  SaveViewport: TPoint;
  Region: HRGN;
  DC: HDC;
  IsBeginPaint: Boolean;
begin
  BufferBitMap := 0;
  BufferDC := 0;
  DC := 0;
  Region := 0;
  IsBeginPaint := Message.DC = 0;

  try
    if IsBeginPaint then
    begin
      DC := BeginPaint(Handle, PS);
      {$IFDEF VER230UP}
      if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
        UpdateRect := ClientRect
        // I had to use a crutch to ClientRect, due to the fact that
        // VCL.Styles.TCustomStyle.DoDrawParentBackground NOT use relative coordinates,
        // ie ignores SetViewportOrgEx!
        // This function uses ClientToScreen and ScreenToClient for coordinates calculation!
      else
      {$endif}
        UpdateRect := PS.rcPaint;
    end
    else
    begin
      DC := Message.DC;
      {$IFDEF VER230UP}
      if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
        UpdateRect := ClientRect
      else
      {$endif}
        if GetClipBox(DC, UpdateRect) = ERROR then
          UpdateRect := ClientRect;
    end;

    //------------------------------------------------------------------------------------------------
    // Duplicate code, see PaintWindow, Please sync this code!!!
    //------------------------------------------------------------------------------------------------
    // if control not double buffered then create or assign buffer
    if not DoubleBuffered then
    begin
      BufferDC := CreateCompatibleDC(DC);
      // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
      // return <> 0 => need to double buffer || return = 0 => no need to double buffer
      if BufferDC <> 0 then
      begin
        // Using the cache if possible
        if FIsCachedBuffer or FIsFullSizeBuffer then
        begin
          // Create cache if need
          if CacheBitmap = 0 then
          begin
            BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
            // Assign to cache if need
            if FIsCachedBuffer then
              CacheBitmap := BufferBitMap;
          end
          else
            BufferBitMap := CacheBitmap;

          // Assign region for minimal overdraw
          Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
          SelectClipRgn(BufferDC, Region);
        end
        else
          // Create buffer
          BufferBitMap := CreateCompatibleBitmap(DC,
            UpdateRect.Right - UpdateRect.Left, UpdateRect.Bottom - UpdateRect.Top);
        // Select buffer bitmap
        SelectObject(BufferDC, BufferBitMap);
        // [change coord], if need
        // Moving update region to the (0,0) point
        if not(FIsCachedBuffer or FIsFullSizeBuffer) then
        begin
          GetViewportOrgEx(BufferDC, SaveViewport);
          SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
        end;
      end
      else
        BufferDC := DC;
    end
    else
      BufferDC := DC;
    //------------------------------------------------------------------------------------------------

    // DEFAULT HANDLER:
    Message.DC := BufferDC;
    inherited PaintHandler(Message);

  finally
    try
      //------------------------------------------------------------------------------------------------
      // Duplicate code, see PaintWindow, Please sync this code!!!
      //------------------------------------------------------------------------------------------------
      try
        // draw to window
        if not DoubleBuffered then
        begin
          if not(FIsCachedBuffer or FIsFullSizeBuffer) then
          begin
            // [restore coord], if need
            SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
          end
          else
          begin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finally
        if BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0 then
          DeleteObject(Region);
        // delete buffer, if need
        if not FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------
    finally
      // end paint, if need
      if IsBeginPaint then
        EndPaint(Handle, PS);
    end;
  end;
end;

{ TODO -cMAJOR : 22.02.2013:
 See: PaintHandler,
 need eliminate duplication of code! }
procedure TEsCustomControl.PaintWindow(DC: HDC);
var
  TempDC: HDC;
  UpdateRect: TRect;
  //---
  BufferDC: HDC;
  BufferBitMap: HBITMAP;
  Region: HRGN;
  SaveViewport: TPoint;
  BufferedThis: Boolean;
begin
  BufferBitMap := 0;
  Region := 0;
  BufferDC := 0;

  if GetClipBox(DC, UpdateRect) = ERROR then
    UpdateRect := ClientRect;

  BufferedThis := not BufferedChildren;

  // fix for designer selection
  BufferedThis := BufferedThis or (csDesigning in ComponentState);

  try
    if BufferedThis then
    begin
    //------------------------------------------------------------------------------------------------
    // Duplicate code, see PaintHandler, Please sync this code!!!
    //------------------------------------------------------------------------------------------------
      // if control not double buffered then create or assign buffer
      if not DoubleBuffered then
      begin
        BufferDC := CreateCompatibleDC(DC);
        // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
        // return <> 0 => need to double buffer || return = 0 => no need to double buffer
        if BufferDC <> 0 then
        begin
          // Using the cache if possible
          if FIsCachedBuffer or FIsFullSizeBuffer then
          begin
            // Create cache if need
            if CacheBitmap = 0 then
            begin
              BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
              // Assign to cache if need
              if FIsCachedBuffer then
                CacheBitmap := BufferBitMap;
            end
            else
              BufferBitMap := CacheBitmap;

            // Assign region for minimal overdraw
            Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
            SelectClipRgn(BufferDC, Region);
          end
          else
            // Create buffer
            BufferBitMap := CreateCompatibleBitmap(DC, RectWidth(UpdateRect), RectHeight(UpdateRect));
          // Select buffer bitmap
          SelectObject(BufferDC, BufferBitMap);
          // [change coord], if need
          // Moving update region to the (0,0) point
          if not(FIsCachedBuffer or FIsFullSizeBuffer) then
          begin
            GetViewportOrgEx(BufferDC, SaveViewport);
            SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
          end;
        end
        else
          BufferDC := DC;
      end
      else
        BufferDC := DC;
    //------------------------------------------------------------------------------------------------
    end else
      BufferDC := DC;

    if not(csOpaque in ControlStyle) then
      if ParentBackground then
      begin
        if FIsCachedBackground then
        begin
          if CacheBackground = 0 then
          begin
            TempDC := CreateCompatibleDC(DC);
            CacheBackground := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
            SelectObject(TempDC, CacheBackground);
            DrawBackground(TempDC); //DrawParentImage(Self, TempDC, False);
            DeleteDC(TempDC);
          end;
          TempDC := CreateCompatibleDC(BufferDC);
          SelectObject(TempDC, CacheBackground);
          if not FIsCachedBuffer then
            BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY)
          else
            BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          DeleteDC(TempDC);
        end
        else
          DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False);
      end else
        if (not DoubleBuffered or (DC <> 0)) then
          if not IsStyledClientControl(Self) then
            FillRect(BufferDC, ClientRect, Brush.Handle)
          else
          begin
            SetDCBrushColor(BufferDC,
              ColorToRGB({$ifdef VER230UP}StyleServices.GetSystemColor(Color){$else}Color{$endif}));
            FillRect(BufferDC, ClientRect, GetStockObject(DC_BRUSH));
          end;

    FCanvas.Lock;
    try
      Canvas.Handle := BufferDC;
      TControlCanvas(Canvas).UpdateTextFlags;

      if Assigned(FOnPainting) then
        FOnPainting(Self, Canvas, ClientRect);
      Paint;
      if Assigned(FOnPaint) then
        FOnPaint(Self, Canvas, ClientRect);
    finally
      FCanvas.Handle := 0;
      FCanvas.Unlock;
    end;

  finally
    if BufferedThis then
    begin
      //------------------------------------------------------------------------------------------------
      // Duplicate code, see PaintHandler, Please sync this code!!!
      //------------------------------------------------------------------------------------------------
      try
        // draw to window
        if not DoubleBuffered then
        begin
          if not(FIsCachedBuffer or FIsFullSizeBuffer) then
          begin
            // [restore coord], if need
            SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
          end
          else
          begin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finally
        if BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0 then
          DeleteObject(Region);
        // delete buffer, if need
        if not FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------
    end;
  end;
end;

// ok
function TEsCustomControl.IsBufferedChildrenStored: Boolean;
begin
  Result := not ParentBufferedChildren;
end;

// ok
procedure TEsCustomControl.SetBufferedChildren(const Value: Boolean);
begin
  if Value <> FBufferedChildren then
  begin
    FBufferedChildren := Value;
    FParentBufferedChildren := False;
    NotifyControls(CM_PARENT_BUFFEREDCHILDRENS_CHANGED);
  end;
end;

procedure TEsCustomControl.SetIsCachedBackground(Value: Boolean);
begin
  if Value <> FIsCachedBackground then
  begin
    FIsCachedBackground := Value;
    if not FIsCachedBackground then BitmapDeleteAndNil(CacheBackground);
  end;
end;

procedure TEsCustomControl.SetIsCachedBuffer(Value: Boolean);
begin
  if Value <> FIsCachedBuffer then
  begin
    FIsCachedBuffer := Value;
    if not FIsCachedBuffer then BitmapDeleteAndNil(CacheBitmap);
  end;
end;

procedure TEsCustomControl.SetIsDrawHelper(const Value: Boolean);
begin
  if Value <> FIsDrawHelper then
  begin
    FIsDrawHelper := Value;
    if csDesigning in ComponentState then
      Invalidate;
  end;
end;

procedure TEsCustomControl.SetIsFullSizeBuffer(const Value: Boolean);
begin
  DeleteCache;
end;

// ok
procedure TEsCustomControl.SetIsOpaque(const Value: Boolean);
begin
  if Value <> (csOpaque in ControlStyle) then
  begin
    if Value then
      ControlStyle := ControlStyle + [csOpaque]
    else
      ControlStyle := ControlStyle - [csOpaque];

    Invalidate;
  end;
end;

// ok
procedure TEsCustomControl.SetParentBufferedChildren(const Value: Boolean);
begin
  if Value <> FParentBufferedChildren then
  begin
    FParentBufferedChildren := Value;

    if (Parent <> nil) and not (csReading in ComponentState) then
      Perform(CM_PARENT_BUFFEREDCHILDRENS_CHANGED, 0, 0);
  end;
end;

procedure TEsCustomControl.SetTransparent(const Value: Boolean);
begin
  ParentBackground := Value;
end;

procedure TEsCustomControl.UpdateBackground;
begin
  UpdateBackground(True);
end;

procedure TEsCustomControl.UpdateText;
begin
end;

procedure TEsCustomControl.UpdateBackground(Repaint: Boolean);
begin
  // Delete cache background
  BitmapDeleteAndNil(CacheBackground);

  if Repaint then Invalidate;
end;

procedure TEsCustomControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  if DoubleBuffered then
  begin
    inherited;
    // Message.Result := 1;
  end else
  begin
    if ControlCount <> 0 then
      DrawBackgroundForOpaqueControls(Message.DC);
    Message.Result := 1;
  end;
end;

//procedure TEsCustomControl.WMNCHitTest(var Message: TWMNCHitTest);
//begin
//  if (FIsTransparentMouse) and not(csDesigning in ComponentState) then
//    Message.Result := HTTRANSPARENT
//  else
//    inherited;
//end;

procedure TEsCustomControl.WMPaint(var Message: TWMPaint);
begin
  ControlState := ControlState + [csCustomPaint];

  // buffered childen aviable only for not DoubleBuffered controls
  if BufferedChildren and (not FDoubleBuffered) and
     not (csDesigning in ComponentState) then // fix for designer selection
  begin
    PaintHandler(Message)// My new PaintHandler
  end else
    inherited;

  ControlState := ControlState - [csCustomPaint];
end;

procedure TEsCustomControl.WMSize(var Message: TWMSize);
begin
  DeleteCache;
  inherited;
end;

procedure TEsCustomControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  if not (csOpaque in ControlStyle) and ParentBackground{ and not CachedBackground }then
    Invalidate;
  Inherited;
end;

{$IFDEF VER180UP}
{ TEsBaseLayout }

constructor TEsBaseLayout.Create(AOwner: TComponent);
begin
  inherited;

  FBufferedChildren := True;
end;

procedure TEsBaseLayout.AdjustClientRect(var Rect: TRect);
begin
  inherited AdjustClientRect(Rect);
  if BorderWidth <> 0 then
  begin
    InflateRect(Rect, -Integer(BorderWidth), -Integer(BorderWidth));
  end;
end;

procedure TEsBaseLayout.AlignControls(AControl: TControl; var Rect: TRect);
begin
  inherited AlignControls(AControl, Rect);
  if (csDesigning in ComponentState) and IsDrawHelper then
    Invalidate;
end;

procedure TEsBaseLayout.CalcContentMargins(var Margins: TContentMargins);
begin
  Margins.Create(Padding.Left, Padding.Top, Padding.Right, Padding.Bottom);
  if BorderWidth <> 0 then
    Margins.Inflate(Integer(BorderWidth), Integer(BorderWidth));
end;

function TEsBaseLayout.ContentMargins: TContentMargins;
begin
  Result.Reset;
  CalcContentMargins(Result);
end;

function TEsBaseLayout.ContentRect: TRect;
var
  ContentMargins: TContentMargins;
begin
  Result := ClientRect;

  ContentMargins.Reset;
  CalcContentMargins(ContentMargins);

  Inc(Result.Left, ContentMargins.Left);
  Inc(Result.Top, ContentMargins.Top);
  Dec(Result.Right, ContentMargins.Right);
  Dec(Result.Bottom, ContentMargins.Bottom);

  {$ifdef TEST_CONTROL_CONTENT_RECT}
  if Result.Left > Result.Right then
    Result.Right := Result.Left;
  if Result.Top > Result.Bottom then
    Result.Bottom := Result.Top;
  {$endif}
end;

procedure TEsBaseLayout.Paint;
begin
  if (csDesigning in ComponentState) and IsDrawHelper then
    DrawControlHelper(Self, [hoBorder, hoPadding, hoClientRect]);
end;

procedure TEsBaseLayout.SetBorderWidth(const Value: TBorderWidth);
begin
  if Value <> FBorderWidth then
  begin
    FBorderWidth := Value;
    Realign;
    Invalidate;
  end;
end;

{ TEsGraphicControl }

procedure TEsGraphicControl.CalcContentMargins(var Margins: TContentMargins);
begin
  if FPadding <> nil then
    Margins.Create(Padding.Left, Padding.Top, Padding.Right, Padding.Bottom)
  else
    Margins.Reset;
end;

function TEsGraphicControl.ContentMargins: TContentMargins;
begin
  Result.Reset;
  CalcContentMargins(Result);
end;

function TEsGraphicControl.ContentRect: TRect;
var
  ContentMargins: TContentMargins;
begin
  Result := ClientRect;

  ContentMargins.Reset;
  CalcContentMargins(ContentMargins);

  Inc(Result.Left, ContentMargins.Left);
  Inc(Result.Top, ContentMargins.Top);
  Dec(Result.Right, ContentMargins.Right);
  Dec(Result.Bottom, ContentMargins.Bottom);

  {$ifdef TEST_CONTROL_CONTENT_RECT}
  if Result.Left > Result.Right then
    Result.Right := Result.Left;
  if Result.Top > Result.Bottom then
    Result.Bottom := Result.Top;
  {$endif}
end;

destructor TEsGraphicControl.Destroy;
begin
  FPadding.Free;
  inherited;
end;

function TEsGraphicControl.GetPadding: TPadding;
begin
  if FPadding = nil then
  begin
    FPadding := TPadding.Create(nil);
    FPadding.OnChange := PaddingChange;
  end;
  Result := FPadding;
end;

function TEsGraphicControl.HasPadding: Boolean;
begin
  Result := FPadding <> nil;
end;

procedure TEsGraphicControl.PaddingChange(Sender: TObject);
begin
  AdjustSize;
  Invalidate;
  if (FPadding.Left = 0) and (FPadding.Top = 0) and (FPadding.Right = 0) and (FPadding.Bottom = 0) then
    FreeAndNil(FPadding);
end;

procedure TEsGraphicControl.Paint;
begin
  if (csDesigning in ComponentState) and IsDrawHelper then
    DrawControlHelper(Self, [hoPadding, hoClientRect]);
end;

procedure TEsGraphicControl.SetIsDrawHelper(const Value: Boolean);
begin
  if FIsDrawHelper <> Value then
  begin
      FIsDrawHelper := Value;
      if csDesigning in ComponentState then
        Invalidate;
  end;
end;

procedure TEsGraphicControl.SetPadding(const Value: TPadding);
begin
  Padding.Assign(Value);
end;

{ TContentMargins }

constructor TContentMargins.Create(Left, Top, Right, Bottom: TMarginSize);
begin
  Self.Left := Left;
  Self.Top := Top;
  Self.Right := Right;
  Self.Bottom := Bottom;
end;

procedure TContentMargins.Reset;
begin
  Left := 0;
  Top := 0;
  Right := 0;
  Bottom := 0;
end;

function TContentMargins.Height: TMarginSize;
begin
  Result := Top + Bottom;
end;

procedure TContentMargins.Inflate(DX, DY: Integer);
begin
  Inc(Left, DX);
  Inc(Right, DX);
  Inc(Top, DY);
  Inc(Bottom, DY);
end;

procedure TContentMargins.Inflate(DLeft, DTop, DRight, DBottom: Integer);
begin
  Inc(Left, DLeft);
  Inc(Right, DRight);
  Inc(Top, DTop);
  Inc(Bottom, DBottom);
end;

function TContentMargins.Width: TMarginSize;
begin
  Result := Left + Right;
end;
{$ENDIF}

end.

Но лучше использовать бесплатную библиотеку VCL компонентов EsVclComponents, которая содержит в себе данные модули и еще много полезных компонентов и классов:
https://github.com/errorcalc/FreeEsVclComponents (библиотека также доступна в пакетном менеджере GetIt для Delphi Berlin, правда не самая свежая версия).

Посмотрите примеры, особенно "\Samples\BufferedChildrens", где видно "магию" подавления мерцания.

Возможно стоит написать отдельную обзорную статью о данной библиотеке?

Спасибо что дочитали статью до конца! Надеюсь, я помог вам побороть проблему мерцания в ваших приложениях и компонентах.

Вы можете помочь проекту, написав мне, где вы используете данные компоненты и приложив скриншот с примером использования.

Tags:

Hubs: