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


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


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


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


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



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


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


Класс имеет свойство BufferedChildrens, при активации которого отрисовка вложенных 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_PAINT, 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 BufferedChildrens;

  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];
  if BufferedChildrens and (not FDoubleBuffered or (Message.DC <> 0)) then
  begin
    PaintHandler(Message)// My new PaintHandler
  end
  else
    inherited;// WMPaint(Message);
  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 ParentBufferedChildrens: Boolean read FParentBufferedChildrens write SetParentBufferedChildrens default True;
    property BufferedChildrens: Boolean read FBufferedChildrens write SetBufferedChildrens stored IsBufferedChildrensStored;
    // 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 IsTransparentMouse: Boolean read FIsTransparentMouse write FIsTransparentMouse default False;
    property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write FIsFullSizeBuffer default False;
  end;

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


image


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


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


image


Для примера можно рассмотреть компонент 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;

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 BufferedChildrens;// 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 ParentBufferedChildrens;// 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;

implementation

uses
  ES.ExGraphics;

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;

end.

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


И под спойлером
{******************************************************************************}
{                       EsVclComponents/EsVclCore v2.0                         }
{                           ErrorSoft(c) 2009-2017                             }
{                                                                              }
{                     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 = 2.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;
    StoredCachedBuffer: Boolean;
    StoredCachedBackground: Boolean;
    FBufferedChildrens: Boolean;
    FParentBufferedChildrens: Boolean;
    FIsFullSizeBuffer: Boolean;
    // paint events
    FOnPaint: TPaintEvent;
    FOnPainting: TPaintEvent;
    // draw helper
    FIsDrawHelper: Boolean;
    // transparent mouse
    // FIsTransparentMouse: Boolean;
    // paint
    procedure SetIsCachedBuffer(Value: Boolean);
    procedure SetIsCachedBackground(Value: Boolean);
    procedure SetIsDrawHelper(const Value: Boolean);
    procedure SetIsOpaque(const Value: Boolean);
    function GetIsOpaque: Boolean;
    procedure SetBufferedChildrens(const Value: Boolean);
    procedure SetParentBufferedChildrens(const Value: Boolean);
    function GetTransparent: Boolean;
    procedure SetTransparent(const Value: Boolean);
    function IsBufferedChildrensStored: 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;
  protected
    // paint
    property Canvas: TCanvas read FCanvas;
    procedure DeleteCache;{$IFDEF VER210UP}inline;{$ENDIF}
    procedure Paint; virtual;
    procedure BeginCachedBuffer;{$IFDEF VER210UP}inline;{$ENDIF}
    procedure EndCachedBuffer;{$IFDEF VER210UP}inline;{$ENDIF}
    procedure BeginCachedBackground;{$IFDEF VER210UP}inline;{$ENDIF}
    procedure EndCachedBackground;{$IFDEF VER210UP}inline;{$ENDIF}
    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 ParentBufferedChildrens: Boolean read FParentBufferedChildrens write SetParentBufferedChildrens default True;
    property BufferedChildrens: Boolean read FBufferedChildrens write SetBufferedChildrens stored IsBufferedChildrensStored;
    // 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 IsTransparentMouse: Boolean read FIsTransparentMouse write FIsTransparentMouse default False;
    property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write FIsFullSizeBuffer 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
    function ContentRect: TRect; virtual;
    function ContentMargins: TContentMargins; inline;
    property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0;
  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); 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);
var
  Canvas: TCanvas;
  Padding: TPadding;
  BorderWidth: Integer;
  MyCanvas: Boolean;
begin
  MyCanvas := False;
  Canvas := nil;
  Padding := nil;
  BorderWidth := 0;

  // if win control
  if Control is TWinControl then
  begin
    // 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
    DrawControlHelper(Canvas, Control.ClientRect, 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_PAINT, 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;

{ TESCustomControl }

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

procedure TEsCustomControl.BeginCachedBackground;
begin
  if CacheBackground <> 0 then BitMapDeleteAndNil(CacheBackground);
  StoredCachedBackground := FIsCachedBackground;
  FIsCachedBackground := True;
end;

procedure TEsCustomControl.BeginCachedBuffer;
begin
  if CacheBitmap <> 0 then BitMapDeleteAndNil(CacheBitmap);
  StoredCachedBuffer := FIsCachedBuffer;
  FIsCachedBuffer := True;
end;

procedure TEsCustomControl.CMParentBufferedChildrensChanged(var Message: TMessage);
begin
  if FParentBufferedChildrens then
  begin
    if Parent <> nil then
    begin
      if Parent is TEsCustomControl then
        BufferedChildrens := TEsCustomControl(Parent).BufferedChildrens
      else
        BufferedChildrens := False;
    end;
    FParentBufferedChildrens := 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);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  ControlStyle := ControlStyle - [csOpaque] + [csParentBackground];
  {$IFDEF VER210UP}
  ParentDoubleBuffered := False;
  {$ENDIF}
  FParentBufferedChildrens := True;// !!
  CacheBitmap := 0;
  CacheBackground := 0;
  FIsCachedBuffer := False;
  FIsCachedBackground := False;
end;

procedure TEsCustomControl.DeleteCache;
begin
  if CacheBitmap <> 0 then BitMapDeleteAndNil(CacheBitmap);
  if CacheBackground <> 0 then BitMapDeleteAndNil(CacheBackground);
end;

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

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

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;
//    if (Control is TGraphicControl) and (Control is TSpeedButton) and (csOpaque in Control.ControlStyle) and
//      Control.Visible and (not (csDesigning in ComponentState) or not (csDesignerHide in Control.ControlState) and
//      not (csNoDesignVisible in ControlStyle)) then
//        FillRect(DC, Rect(Control.Left, Control.Top, Control.Left + Control.Width, Control.Top + Control.Height), Brush.Handle);
  end;
end;

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

procedure TEsCustomControl.EndCachedBuffer;
begin
  FIsCachedBuffer := StoredCachedBuffer;
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;

{$ifdef VER210UP} {$REGION 'BACKUP'}
(*
// Main magic located here:
procedure TESCustomControl.PaintWindow(DC: HDC);
var
  BufferDC, TempDC: HDC;
  BufferBitMap: HBITMAP;
  UpdateRect: TRect;
  SaveViewport: TPoint;
  Region: HRGN;
begin
  //UpdateRect := Rect(0, 0, Width, Height);
  //GetClipBox(DC, UpdateRect);
  if GetClipBox(DC, UpdateRect) = ERROR then
    UpdateRect := Rect(0, 0, Width, Height);

  if not DoubleBuffered then
  begin
    BufferDC := CreateCompatibleDC(DC);
    // for bitmap context
    if BufferDC = 0 then
      BufferDC := DC
    else
    begin
      if FCachedBuffer then
      begin
        if CacheBuffer = 0 then
          CacheBuffer := CreateCompatibleBitmap(DC, Width, Height);
        BufferBitMap := CacheBuffer;
        Region := CreateRectRgn(0, 0, UpdateRect.Width, UpdateRect.Height);
        SelectClipRgn(BufferDC, Region);
      end
      else
        BufferBitMap := CreateCompatibleBitmap(DC, UpdateRect.Width, UpdateRect.Height);
      SelectObject(BufferDC, BufferBitMap);
    end;
  end
  else
    BufferDC := DC;

  // change coord
  if (not DoubleBuffered){ and (not FCachedBuffer)} then
  begin
    GetViewportOrgEx(BufferDC, SaveViewport);
    SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
  end;

  if not(csOpaque in ControlStyle) then
    if ParentBackground then
    begin
      if FCachedBackground then
      begin
        if CacheBackground = 0 then
        begin
          TempDC := CreateCompatibleDC(DC);
          CacheBackground := CreateCompatibleBitmap(DC, Width, Height);
          SelectObject(TempDC, CacheBackground);
          DrawParentImage(Self, TempDC, False);
          DeleteDC(TempDC);
        end;
        TempDC := CreateCompatibleDC(BufferDC);
        SelectObject(TempDC, CacheBackground);
        BitBlt(BufferDC, 0, 0, UpdateRect.Width, UpdateRect.Height, TempDC, 0, 0, SRCCOPY);
        DeleteDC(TempDC);
      end
      else
        DrawParentImage(Self, BufferDC, False);
    end else
      if (not DoubleBuffered) then
        FillRect(BufferDC, Rect(0, 0, Width, Height), Brush.Handle);

  FCanvas.Lock;
  try
    Canvas.Handle := BufferDC;
    TControlCanvas(Canvas).UpdateTextFlags;
    Paint;
    //Canvas.Brush.Color := Random(256*256*256);
    //Canvas.FillRect(Updaterect);
  finally
    FCanvas.Handle := 0;
    FCanvas.Unlock;
  end;

  if IsDrawHelper and(csDesigning in ComponentState) then
  begin
    SetBkColor(BufferDC, RGB(127,255,255));
    DrawFocusRect(BufferDC, self.ClientRect);//self.ClientRect);// for Design
  end;

  // restore coord
  if (not DoubleBuffered){ and (not FCachedBuffer)} then
    SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);

  if not DoubleBuffered then
  begin
    if not FCachedBuffer then
      BitBlt(DC, UpdateRect.Left, UpdateRect.Top, UpdateRect.Width, UpdateRect.Height, BufferDC, 0, 0, SRCCOPY)
    else
    begin
      //BitBlt(DC, UpdateRect.Left, UpdateRect.Top, UpdateRect.Width, UpdateRect.Height, BufferDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY);
      BitBlt(DC, UpdateRect.Left, UpdateRect.Top, UpdateRect.Width, UpdateRect.Height, BufferDC, 0, 0, SRCCOPY);
      DeleteObject(Region);
    end;
    DeleteDC(BufferDC);
  end;

  if not FCachedBuffer and (BufferBitMap <> 0) then DeleteObject(BufferBitMap);
end;
*)
{$ENDREGION} {$endif}

{ 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 BufferedChildrens;

  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;

function TEsCustomControl.IsBufferedChildrensStored: Boolean;
begin
  Result := not ParentBufferedChildrens;
end;

procedure TEsCustomControl.SetBufferedChildrens(const Value: Boolean);
begin
  if Value <> FBufferedChildrens then
  begin
    FBufferedChildrens := Value;
    FParentBufferedChildrens := 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
  FIsDrawHelper := Value;
  if csDesigning in ComponentState then Invalidate;
end;

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

procedure TEsCustomControl.SetParentBufferedChildrens(const Value: Boolean);
begin
  //FParentBufferedChildrens := Value;
  if Value <> FParentBufferedChildrens then
  begin
//    if (Parent <> nil) and Value then
//    begin
//      if Parent is TESCustomControl then
//        BufferedChildrens := TESCustomControl(Parent).BufferedChildrens
//      else
//        BufferedChildrens := False;
//    end
//    else
//      if Value then
//        BufferedChildrens := False;
//    FParentBufferedChildrens := Value;
    FParentBufferedChildrens := 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
  if CacheBackground <> 0 then BitMapDeleteAndNil(CacheBackground);
  if Repaint then Invalidate;
end;

procedure TEsCustomControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  if DoubleBuffered {and not(csOpaque in ControlStyle)} then
  begin
    Inherited;
    Message.Result := 1;
    exit;
  end;
  if ControlCount <> 0 then
    DrawBackgroundForOpaqueControls(Message.DC);
  Message.Result := 1;
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];
  if BufferedChildrens and (not FDoubleBuffered or (Message.DC <> 0)) then
  begin
    PaintHandler(Message)// My new PaintHandler
  end
  else
    inherited;// WMPaint(Message);
  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 }

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", где видно "магию" подавления мерцания.


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


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


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

Поделиться с друзьями
-->

Комментарии (88)


  1. A-Stahl
    06.01.2017 19:39
    -42

    >Delphi… C++Builder… VCL
    Бедняжка… За что тебя так? Ты хоть адрес напиши — мы тут тебе передачку соберём. Пару бутылок пива, сигареты, gcc, какую-то IDE…


    1. Error1024
      06.01.2017 19:43
      +25

      Минусанул тебе карму, ибо достали уже такие «знатоки».


      1. Daar
        08.01.2017 11:43
        +2

        Согласен. Досих пор использую Delphi 7 которую купил лет еще 15 назад (как то даже диск на глаза попадался :) ). Не спорю это не основная среда разработки, но если надо реально за 30 минут накидать виндовое приложение и которое будет работать практически везде и кроме переноса exe-файла ничего не требует (BDE не использую :) ), то это идеальна вещь. Некоторые проги написанные 10 лет назад все еще работают у людей и они их меня не хотят.

        И чего душой кривить, вот 30 числа нужно было срочно написать конвертор для больших файлов для отправки в ЕГАИС… реально 20 минут и готово.


    1. Danik-ik
      07.01.2017 14:20
      +1

      Нам, дельфистам, некогда курить и пить пиво — работы много. И если честно, не видно внятных альтернатив для решения конкретного ряда задач.


      К примеру: система финансово-управленческого учёта специального назначения, Windows native (требование спорное, но оно есть), ничего лишнего, максимальная эргономика с защитой от дурака и зловреда, минимальное время реакции на изменяющиеся требования бизнеса, минимальные требования к инфраструктурному обеспечению (типа ничего, кроме sql сервера).


      Предложите альтернативу, я рассмотрю. Честно-честно. Давно хочу альтернативу.


      1. A-Stahl
        07.01.2017 14:40
        -5

        >Предложите альтернативу, я рассмотрю.
        Qt+cpp;
        Кроссплатформенность, поддержка современных компиляторов…
        Если бы автор написал «Lazarus», то я слова бы не сказал. Паскаль так паскаль. Но Дельфи…
        Я даже не удивлён такой негативной реакции на мою безобидную шутку — уверен, что над вами, дельфистами, смеются все и всегда. Вы уже, похоже, не в состоянии понимать шутки, а про самоиронию вы забыли ещё в 2000х.


        1. DrPass
          07.01.2017 14:51
          +3

          Qt+cpp;

          Это в лучшем случае шило на мыло. Ну т.е. если вы знаете C++, и вам нужна среда быстрой разработки толстых, но нативных приложений, то Qt для вас вполне годится. Но мигрировать на неё с Delphi, это просто головная боль, куча времени на поиск новых граблей, и ноль преимуществ в итоге.


          1. A-Stahl
            07.01.2017 15:45
            -8

            Гхм. А Дельфи нынче какой версии используется? Что его компилятор знает про современные процессоры?
            Ничего? Ну это же никому не нужно, правильно?
            Оптимизации? Какие оптимизации? Прогресс в этом направлении остановился в 2008, не так ли. (Нет, прогресс не остановился? Вы кормите мудаков из Эмбракадеро? Ну кто-то же должен кормить мудаков...)
            Qt слишком толстый? Что, есть ещё виндовые машины где лишние 8-9МиБ слишком чувствительны? Впрочем, сомневаюсь, что футпринт дельфи значительно меньше.
            Но даже если Qt слишком толстый, то есть GTK. Он куда более худой.

            P.S. Обиженки с головной болью слили карму, так что я буду отвечать довольно редко. (Кстати, что же нужно иметь в голове, чтобы затыкать человеку рот на целом сайте? Боль, вероятно… и похоже нифига не головную, а ближе к точке возгорания:) )


            1. Error1024
              07.01.2017 16:09
              +5

              Вы кормите мудаков из Эмбракадеро? Ну кто-то же должен кормить мудаков...)

              Извини, но ты мудак ;)
              На остальное отвечать тебе не вижу смысла.
              Поразительно то, что к каждой статье про Delphi найдется такой мудак, не способный пройти мимо. Благо теперь стали минусовать их.


              1. torf2505
                10.01.2017 13:32
                +1

                Не стоит опускаться до их уровня…


            1. an24
              07.01.2017 17:51
              +3

              Я тоже чего-то не понял, почему компилятор Delphi, по вашему мнению, не развивается? И вообще возникло сомнения, — а знаете ли вы что представляют собой современная версия Delphi?


              1. torf2505
                10.01.2017 13:33
                +1

                Убеждать апологетов — бесполезно


                1. ZblCoder
                  10.01.2017 14:07
                  +2

                  В своё время, ко мне на стримы заходили толпы людей, и пытались убедить, что Delphi умер и стоит разрабатывать на других языках. При этом никто не мог обосновать свою логику. Некоторые уходили с пониманием, некоторые шли искать других, чтобы склонять в свою веру.


            1. DrPass
              07.01.2017 21:29
              +3

              Вы кормите мудаков из Эмбракадеро?

              Так, чисто для справки: коммерческая лицензия на Qt стоит порядка $150/месяц.


              1. A-Stahl
                07.01.2017 21:59
                -6

                >коммерческая лицензия на Qt стоит
                Вот только покупать её нужно в исключительнейших случаях. В основном тогда, когда необходимо внести правки в сам код Qt или когда кровь из носа нужна статическая линковка. Остальным хватает LGPL и динамической линковки за бесплатно.
                Сравнение ещё менее корректно хотя бы уже потому, что в код Дельфи внести изменения вообще невозможно (В жизни не поверю что жлобо-рептилоиды из эмбракадеро открыли код).


                1. Error1024
                  07.01.2017 22:02
                  +3

                  Вообще-то исходный код RTL, VCL, FMX входит в поставку.


                1. stychos
                  08.01.2017 18:04
                  +2

                  Вот только покупать её нужно в исключительнейших случаях.

                  Ага, или элементарно захотеть статическую компиляцию, чтобы не распространять приложение с тоннами говна.


              1. Darthman
                09.01.2017 13:09
                +2

                А Starter версия делфи нынче вообще бесплатна, да. И уже давно принадлежит конторе с назнваием IDERA. Тоже так, чисто для справки.


                1. torf2505
                  10.01.2017 13:34

                  Бесплатны почти все образовательные лицензии…


                  1. Darthman
                    10.01.2017 13:37

                    До осени того года стартер был 300+ баксов. Я в своё время ХЕ5 покупал тысяч за 8 рублей…


          1. sborisov
            09.01.2017 12:10

            На Qt будет дольше, с БД работать если и что-то кастомизировать, нужно написать модельки свои, делегатики. В Дельфи это займёт 5 минут мышекликаньем. RAD конечно лучше, чем в Дельфи никто не сделал.


        1. Error1024
          07.01.2017 15:06
          +5

          Шутка не должна выглядеть так, было неприятно получить «это» в качестве первого комментария вместо обоснованной критики под своей статьей, тебя заминусовали за это, и не только дельфисты.
          А оправдываться что в случае лазаруса ты бы не оставил здесь свой «полезный» комментарий не стоит.


        1. sasha1024
          08.01.2017 05:41
          +3

          Взгляд со стороны — это тупая шутка.


          1. A-Stahl
            08.01.2017 09:26
            -6

            Шутка отличная, но ты просто не можешь посмотреть со стороны.


            1. sasha1024
              08.01.2017 21:48
              +3

              Об этом судить не автору шутки.


        1. geher
          08.01.2017 13:45
          +1

          1. Lazarus, к сожалению, не является полноценной альтернативой Delphi. Для добавления нового компонента в среду разработки необходима пересборка самой среды разработки, что отнимает немало времени и ломает то самое преимущество "склепал за несколько минут работающее приложение".
          2. QT не подходит по другой причине: у него намного меньше автоматизации при написании кода. Все это мелочи, конечно, но разработку замедляет существенно, что и определяет все то же конкурентное преимущество Delphi — "быстро склепать приложение".

          Единственным реальным конкурентом Delphi (в старом понимании сего бренда, сейчас это дело объединили под общим названием) я назвал бы CBuilder, который использует тот же способ быстрой разработки приложений. Но на C++ RAD технология (если правильно помню ее наименование) ложится из-за особенностей языка гораздо хуже.


          1. sborisov
            09.01.2017 12:18

            С теплотой вспоминаю эти среды разработки.
            Часто встречались на форумах претензии к качеству компилятора у билдера особенно на работу с ссылками. Но по скорости разработки, я в 90х писал и на Дельфи и на Билдере, разницы в принципе никакой не было, на билдере всё было так же быстро и приятно.
            Жаль, что не сделали среду под Линукс нормальную. (Kylix) так и не взлетел, компилятор вроде не исправили, после перехода на ядро 2.4.18 — помнится, поменяли формат ELF файлов, а Борланду было уже не до него.


            1. ElectroGuard
              09.01.2017 13:56

              Линукс собираются на Делфи вновь возродить. Ждём. Лазарь, к слову, уже давно и успешно на линуксе работает и программы на нем пишутся.


      1. Tom910
        08.01.2017 00:05

        Что будете делать, если нужно будет сделать приложение для mac os или мобильных устройств? Я вижу только альтернативу в веб приложениях js/scalajs/clojurescript + react/angular 2 + electron/cordova. Везде работает, одна кодовая база.


        1. DrPass
          08.01.2017 01:42
          +1

          Delphi, как и большинство других современных средств разработки, давно позволяет делать приложения и для мобильных устройств, и для macOS. Надо иметь в виду, что у Delphi немного иная ниша, чем у веб-приложений. Delphi чаще всего используют для разработки бизнес-приложений, где чаще всего предполагается какая-либо активная работа с БД. «Фишка» Delphi, которая с ней была изначально, это удобные биндинги к базам данных и data-aware контролы, особенно гриды. В веб-платформах, к сожалению, ничего столь мощного нет в силу ограничений, накладываемых броузерами (ближе всего подобрался devExpress, но там другие нюансы есть). Поэтому потребность делать мобильные клиенты на Delphi не так часто бывает востребованной. Да и, честно говоря, далеко не всегда выгоднее иметь одну кодовую базу и слои адаптации под разные платформы, чем иметь несколько различных клиентов, каждый из которых оптимизирован под свою платформу.


        1. ElectroGuard
          08.01.2017 13:12
          +3

          Делфи сейчас работает на всех основных платформах — Win32/64, iOS, Android, MacOS, серверный линукс почти сделали. Собранный код по производительности может и проигрывает плюсам в некоторых случаях, но большинство частей библиотек хорошо оптимизированы ассемблером.
          У Лазаруса список поддерживаемых платформ вообще огромен. При том, что он бесплатный, и последние сборки, например, отсюда: https://www.getlazarus.org вполне пригодны для работы. Есть биндинги Qt и Gtk, под виндой и линуксом. Так что для того, что бы работать с Qt совсем не обязательно переходить на плюсы.
          JS, который мы тоже используем, сильно ограничен рамками браузера. Некоторые банальные вещи — например — копирование в буфер в нём сделать просто нельзя. Многие вещи браузеро-зависимые. То есть — получается не просто платформы, а куча браузеров на множестве платформ. Мы активно используем HMLT5, многопоточную обработку, WebGL. У разных браузеров на разных платформах свои особенности. Вместо написания функциональности приходится постоянно заниматься оптимизацией под браузеры.


        1. serbod
          10.01.2017 10:30

          http://www.unigui.com

          Платная, да. По цене смартфона. Есть и бесплатные варианты, например http://www.morfik.com
          Есть backend-фреймворки — https://github.com/silvioprog/brookframework


      1. VVizard
        09.01.2017 13:30

        система финансово-управленческого учёта специального назначения


        ничего лишнего, максимальная эргономика с защитой от дурака и зловреда, минимальное время реакции на изменяющиеся требования бизнеса, минимальные требования к инфраструктурному обеспечению (типа ничего, кроме sql сервера)


        Как вариант платформа 1С 8.3.х. (про цену лицензий в требованиях ничего не было :)). Но если система большая то цена лицензий в стоимости системы занимает от силы 1% ну и Delphi тоже не бесплатная.

        По остальным показателям именно в «финансово-управленческом учёте» 1С вполне способна составить конкуренцию Delphi.
        А если нужно и «минимальное время реакции на изменяющиеся требования бизнеса» то delphi сильно отстает от 1С.


    1. RoseWoodsAlloy
      09.01.2017 17:36

      а таки ваше гецэцэ умеет вицээль? А поддерживать старое легаси писанное и переписанное на дельфях как на гэцеце? Ах да, Reference counting и DCOM+ из коробочки, выньте да положте, пожалуйста…


  1. movnet
    06.01.2017 20:27
    +5

    Спасибо. Будем пробовать.


  1. engune
    06.01.2017 20:27
    +2

    В свое время пользовался Delphi разных версий 3, 4, 5, 6. Большую часть делал интерфейсы, кастомные контролы и псевдо 3D на cos и sin. Были времена, приятно вспомнить.


  1. alexkunin
    06.01.2017 20:29
    +2

    Очень плохо помню, но кажется лет 15 назад все такие проблемы решались перехватом WM_ERASEBKGND и недопуском его дефольтного обработчика, который затирал весь контрол красивым серым цветом. В случае ВЦЛ-компонент, это относится к первому родителю с HWND, «виртуальные» дети которого рисовали сами себя по уже нарисованному.

    При неосторожной отрисовке могли быть артефакты, особенно при перемещении и изменении размера окна. А также с появлением (человеческой реализации) сглаживания шрифтов в винде — частный «глюк»: перерисовываемый текст со сглаживанием становился все жирнее и неразборчивей из-за постоянного наслоения. Зато проблема решалась в одном месте на все приложение.

    Вроде бы ваше решение от такого не страдает (честная отрисовка в невидимый буфер), но вы форсируете «папу» «напечататься» (WM_PRINTCLIENT), а это может иметь побочные эффекты. Лет адцать назад я встречал контролы, которые не давали «печататься» — чтобы нельзя было сделать, скажем, слепок с защищенной пдфки, которую контрол демонстрирует.


    1. dmitryredkin
      06.01.2017 20:44
      -1

      Плюсую WM_ERASEBKGND.
      Изучать надо WinAPI, тогда и проблем не будет.
      Работаю с OWL/VCL более 20 лет. Про «проблему мерцания» слышу в первый раз.


      1. Error1024
        06.01.2017 20:52
        +6

        Откройте стандартный «диспетчер устройств» и попробуйте изменять размер окна, оцените мерцание.
        В VCL также, посмотрите на саму Rad Studio.


      1. SBC
        07.01.2017 22:03
        +1

        О проблеме с мерцанием слышал любой кто что либо отрисовывал самостоятельно


    1. Error1024
      06.01.2017 20:47
      -1

      но вы форсируете «папу» «напечататься» (WM_PRINTCLIENT), а это может иметь побочные эффекты. Лет адцать назад я встречал контролы, которые не давали «печататься» — чтобы нельзя было сделать, скажем, слепок с защищенной пдфки, которую контрол демонстрирует.

      Как я уже писал, класс показал свою надежную работу :)
      Но для таких «кривоватых» контролов я сделал виртуальный метод procedure DrawBackground(DC: HDC); virtual;, в котором для обхода проблем подобных компонентов можно переопределить отрисовку фона.
      Кроме того компонент имеет множество настроек буферизации.


  1. ElectroGuard
    06.01.2017 20:32
    +2

    Спасибо! Интересно.


  1. tsklab
    06.01.2017 20:32
    -2

    Про мерцание уже забыл по двум причинам: не использую большое количество контролов на форме и, наоборот, использую дискретные видео-карты и хорошим 2D-рендерингом.


    1. Error1024
      06.01.2017 20:41
      +2

      К сожалению начиная с Windows Vista, GDI практически перестало использовать 2д ускорение, и к сожалению проблема мерцания никуда не ушла, да о чем говорить — многие стандартные Windows приложения мерцают.


      1. Fortop
        07.01.2017 18:02

        Блин, вы о чем?
        Что за мерцание?


        Пример такого стандартного Windows приложения и как это самое мерцание воспроизвести?


        1. Error1024
          07.01.2017 18:08
          +1

          Как я уже писал: «Откройте стандартный «диспетчер устройств» и попробуйте изменять размер окна, оцените мерцание.».


          1. Fortop
            07.01.2017 18:14

            Windows 10

            Открыл Device Manager — ничего не мерцает, как я ни меняю размер окна.

            С какой частотой и как быстро его надо менять?


            1. Error1024
              07.01.2017 18:25
              +1

              Важно чтобы было не было отключено «Отображать содержимое окна при перетаскивании».
              Можно еще открыть «Управление компьютером» и полистать там вкладки.


              1. Fortop
                07.01.2017 19:52

                Ну предположим, что я совсем идиот, и флаг "отображать содержимое" у меня был отключен.
                Проблема в том, что он был включён и поведение не воспроизводилось.
                Аналогично с вкладками компьютера.


                Вы можете уточнить свою конфигурацию, на которой вы это воспроизводите?


                1. TheRaven
                  08.01.2017 14:18
                  +1

                  Win7, открываю диспетчер задач и начинаю его ресайзить туда-сюда: мерцают верхние вкладки.


                1. agranom555
                  08.01.2017 15:35

                  Последняя стабильная Windows 10. При изменении размера влево вправа мерцает. Не каждое изменение, но мерцает. Попробуйте секунд 5 изменять и увидите


                1. stychos
                  08.01.2017 18:13
                  +1

                  Вы сузьте окно так, чтобы оно закрывало часть верхних вкладок, потом расширяйте — мерцание вкладок обеспечено.


        1. AndrewTishkin
          10.01.2017 17:54

          Я бы в качестве ещё одного примера привёл окно проводника. Особенно момент уменьшения до размера, когда пропадает риббон


  1. msts2017
    06.01.2017 21:18

    странно что вообще проблема с мерцанием еще есть, всмысле, ведь ее решили на уровне винды — «композитор» с висты работает с двойной буферизацией в принципе.


    1. Error1024
      06.01.2017 21:22
      +2

      «композитор» решает проблему композиции только окон верхнего уровня.


      1. msts2017
        06.01.2017 21:30
        -2

        и? как раз для этого он держит буфер для каждого окна и туда пишутся все команды отрисовки а потом результат выводится, мерцание возможно только если дать команду заставляющую «композитор»отрисовать окно на экране.
        да и вообще, прежде чем написать, я проверил — с выключенными темами мерцает с включенными нет.


        1. Error1024
          06.01.2017 21:33
          +3

          Как я уже писал: «Откройте стандартный «диспетчер устройств» и попробуйте изменять размер окна, оцените мерцание.».
          Возможно у вас быстрая машина и вы не успеваете заметить мерцание, или приложение на котором вы проверяете буферизирует отрисовку.


        1. msts2017
          06.01.2017 21:36

          т.е. по хорошему, двойную буферизацию надо отключать когда программу по RDP запустили а с висты еще когда темы включены, как-то так.


          1. Error1024
            06.01.2017 21:39
            +2

            Повторяю — проблема мерцания в классических WinApi приложениях никуда не исчезла, те что не мерцают — сами буферизируют отрисовку или вообще используют один из фреймворков для GUI.


  1. perfect_genius
    06.01.2017 21:39
    +8

    А если моргать синхронно с мерцанием, то мерцание вообще не увидеть =)


    1. ripatti
      07.01.2017 15:26
      +1

      Главное не перепутать фазу моргания — иначе окно будет вообще пропадать.


  1. VaalKIA
    06.01.2017 22:47

    Поднадоели исходники С# и C++ в функциональном стиле, как приятно видеть старый добрый Паскаль, только из-за этого прочёл всю статью, да и в общем-то актуальная тема, но не хватает гифок. Ещё бы с Russian AI CUP какой-нибудь Дельфист выложил мемуары, вообще было бы шикарное начало года.


    1. torf2505
      07.01.2017 13:56

      Присоединяюсь


  1. Klenov_s
    06.01.2017 22:52
    +3

    Очень хотелось почитать какие-нить свежие статьи по free-pascal или delphi, но устранением мерцания в VCL я занимался лет 18-20 назад. Неужели ничего нового с тех пор не возникло?


    1. Error1024
      06.01.2017 22:58

      Проблема мерцания и прозрачности все еще актуальна, по причине актуальности VCL, который базируется на довольно консервативном WinApi.
      Новое есть — если про VCL, то теперь есть поддержка юникода, скинов.
      Появился новый интерфейсный фреймворк — FMX, а с ним и поддержка MacOS, Android, iOS.
      В следующем релизе будет серверный Linux.
      Ну и кончено же в языке много изменений произошло.


  1. Smi1e
    07.01.2017 02:17

    Если позволите, небольшое замечание по имени переменной

    Класс имеет свойство BufferedChildrens

    Используйте Childs или Children (а еще лучше глагол: BufferChilds). Слова Childrens не существует, ибо Children — уже множественное число.


    1. Error1024
      07.01.2017 02:40

      Да, есть ошибка, знаю, но исправить «легко и просто» нельзя к сожалению, это сломает много кода(не моего).
      Но я знаю как можно в течении времени исправить, добавив правильный «двойник» свойства, скрыть в дизайнере неправильное свойство через ToolsApi и т.д., при этом из dfm будет считываться неверное свойство, а записываться будет верное свойство. Если возможно будет исправить не сломав совместимость, то будет исправлено.


  1. alex_ter
    07.01.2017 02:24
    +1

    Небольшое отступление. В MS видимо в курсе проблемы, но для приложений, использующих классический API (в т.ч. это большинство системных) видимо нормального решения нет. Именно по-этому для классов ListView и TreeView они добавили встроенную двойную буферизацию, которая работает явно лучше, предложенной в VCL.
    См. TVS_EX_DOUBLEBUFFER и LVS_EX_DOUBLEBUFFER.


    1. Error1024
      07.01.2017 02:32

      Согласен, у меня в EsVclComponents есть модуль специальный, который включает «родную» буферизацию для TListView: ES.VclFix.pas
      Его достаточно подключить в файле с формой :)


  1. Maccimo
    07.01.2017 08:20
    +3

    {$ifdef VER210UP} {$REGION 'BACKUP'}
    (*
    // Main magic located here:
    procedure TESCustomControl.PaintWindow(DC: HDC);
    var
      BufferDC, TempDC: HDC;
      BufferBitMap: HBITMAP;
      UpdateRect: TRect;
      SaveViewport: TPoint;
      Region: HRGN;
    begin

    Зачем вам система контроля версий, если вы продолжаете хранить полуразложившиеся трупы в комментариях?


    1. alan008
      07.01.2017 11:56
      +2

      (я не автор поста) Иногда удаленный код удобно оставлять в комментариях, чтобы видеть его происхождение через blame/diff. Иначе отследить, что тут когда-то давно был какой-то код, довольно сложно


    1. DrPass
      07.01.2017 13:13
      +3

      Ну потому что если код может вызвать вопросы «откуда это произошло», ответ лучше оставить рядом с кодом, а не заставлять каждого вопрошающего заниматься прикладной археологией в системе контроля версий.


    1. Error1024
      07.01.2017 14:01
      -1

      Ответ уже написали сверху.


  1. kovserg
    07.01.2017 13:57

    На сколько я помню всё можно было буферизировать кроме richedit эта редиска плевать хотела на dc который ей передают и вместо текста получалась дырка от бублика. Вы смогли это победить?


    1. Error1024
      07.01.2017 14:02

      К сожалению RICHEDIT не победить.


      1. Darthman
        09.01.2017 13:12

        Вот и я своё время не смог, и сделал свой редактор текста с подсветкой синтаксиса… Ричэдит страшная штука.


        1. Error1024
          09.01.2017 14:40
          +1

          Кроме всего прочего он имеет много версий, поведение которых немного разное :/


  1. sim31r
    07.01.2017 16:25
    -1

    Иногда использую вариант такой

    memo1.visible.false
    // много изменений в сожержимом
    memo1.visible.true

    нет ни мерцания, и задержка на обращение к компоненту снижается по времени раз в 10, придумал такое «методом тыка». Может кому-то пригодится тоже.


    1. Error1024
      07.01.2017 16:52
      +2

      Настоятельно не рекомендую пользоваться таким способом, вам «повезло» что он работает, но нет никаких гарантий что не сломается или не даст необычные глюки.
      Используйте:

        Memo1.Lines.BeginUpdate;
        try
          // изменения
        finally
          Memo1.Lines.EndUpdate;
        end;
      


      1. sim31r
        07.01.2017 17:08
        -1

        Да, ваш метод лучше. Глюки могут быть, если задержать процесс обновления, компонент просто исчезнет с экрана. Например, при обращении к БД. Только для быстрых изменений, добавления уже готовых данных.


    1. SBC
      07.01.2017 22:14
      +2

      Специально попробовал ваш способ (думал магия есть).
      Мерцания пропало (как и ожидалось), но теперь получился просто исчезающий и появляющийся компонент.
      По мне так лучше будет мерцание, чем моргание всем компонентом ))


      1. sim31r
        08.01.2017 03:19
        -1

        В моем случае, он не успевает моргать, и время процессора не тратится на перерисовку, пример

        memo1.visible.false
        memo1.lines.add('test'); // много изменений
        memo1.clear;
        memo1.lines.add('test');
        memo1.lines.add('test');
        memo1.visible.true

        Но, конечно, метод с BeginUpdate делает всё это лучше.


  1. NoCiphersAllowed
    07.01.2017 18:08
    +1

    Спасибо за статью! Интересный подход.


  1. pascualle
    08.01.2017 21:21
    +2

    Ого! Вот это зачет!
    Помню, сколько я часов провел на форумах, применяя всякие уловки против мерцания… Честно признаюсь, я в то время так и не нашел годного решения. Потому данная статья вызвала лично мне приятную ностальгию, а автору — реальное уважение.

    Я когда-то около трех лет работал с VCL, правда на CBuilder. Задачей было организовать автоматизацию с красивым интерфейсом быстрыми темпами в одном банке. На то время лучшего решения чем Delphi5/CBuilder5 (кому что нравилось) попросту не было. Вот, столько лет прошло, а наши программы до сих пор нормально и успешно там работают без всякого саппорта.

    Теперь же, работая чуть в другой сфере, отойдя от оконных приложений, мне лично, особенно когда надо «нафигачить что-то под винду с окнами побырику» кроме RADStudio я ничего не хочу знать, он меня устраивает всем. На CBuilder, к примеру, я пишу редактор уровней для своего движочка. Правда, чтобы избавиться от мерцания основного поля, я полностью отказался от TCanvas в его классическом применении, рендерю в него прямо OpenGL контекст.


  1. Darthman
    09.01.2017 13:11
    +2

    Спасибо за статью. У меня были свои методы борьбы с таким, но как правило с собственными контролами. Стандартные почти всегда работали вполне приемлемо и так. А сейчас я вообще в делфи ушел в геймдев, поэтому совсем неактуально стало. Но всё-равно любопытно.


  1. ZblCoder
    09.01.2017 13:29
    +2

    Спасибо за статью, часто борюсь с тем или иным мерцанием в своих компонентах. Какие только пути не изобретал.


  1. Volk65
    09.01.2017 16:10
    +1

    Спасибо за статью.


  1. barbanel
    09.01.2017 16:10
    +1

    Присоединяюсь, спасибо за статью и компоненты.
    Уже использую в проекте, обнаружил непонятное поведение TEsLayout при использовании тем.
    Пишу в личку.


    1. barbanel
      09.01.2017 16:15
      +3

      Upd.
      Проблема оказалась в моем коде, компонент работает как ожидается.
      Петр, спасибо!