VCL, get rid of flicker, once and for all

Tutorial

Delphi and C ++ Builder developers using VCL are not aware of the ubiquitous problem of flickering controls. Flickering occurs when redrawing, due to the fact that the background of the component is first drawn, and only then the component itself.

And if in the case of TWinControl heirs, a partial solution to the problem is to set the DoubleBuffered property to True , which forces the control to draw in the buffer (however, DoubleBuffered also does not work perfectly, for example: the control ceases to be transparent), then in the case of TGraphicControl, the solution with DoubleBuffered it is simply impossible, due to the lack of a window for TGraphicControl , setting DoubleBuffered to True by the parent does not help, due to the fact that the drawing of nested TGraphicControls occurs after the parent has been drawn in the buffer.

Usually, there is only one thing left - to put up with flickering, and simplify rendering as much as possible to minimize the effect, or to use TWinControls if possible , which is not always possible and convenient.

Once tormented by flickering, I could not stand it and decided to solve this problem, once and for all!

How did I solve the problem?

I apologize in advance for some confusion of presentation, and understatement, describing such things is quite difficult, but I want to share with the community.

The TEsCustomControl = class (TWinControl) class was developed , which provides alternative buffering (with DoubleBuffered = False , otherwise native VCL buffering is used ).

The class has the BufferedChildren property , when activated, rendering of nested TGraphicControls occurs in the buffer, which completely eliminates flicker.

Fortunately, in VCL, the necessary rendering methods are not declared as private , which made it possible to implement full buffering.

In order for the component to look transparent, you need to draw the background of the underlying component on it, which is done using the DrawParentImage procedure .

procedureDrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);var
  ClientRect: TRect;
  P: TPoint;
  SaveIndex: Integer;
beginif Control.Parent = nilthenExit;
  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) thenbegin
    ClientRect := CalcClientRect(Control);
    SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil);
  endelse
    SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
  Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
  Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT);
  RestoreDC(DC, SaveIndex);
  if InvalidateParent thenifnot (Control.Parent is TCustomControl) andnot (Control.Parent is TCustomForm) andnot (csDesigning in Control.ComponentState)andnot (Control.Parent is TEsCustomControl) thenbegin
      Control.Parent.Invalidate;
    end;
  SetViewportOrgEx(DC, P.X, P.Y, nil);
end;

Buffering occurs due to the fact that the component in the overridden PaintWindow method is not drawn directly on the provided handle, but on a temporary (or not depending on the IsCachedBuffer property ) HBITMAP , and after full rendering is copied by the BitBlt function .

(Quite a lot of code, due to many special cases)

TEsCustomControl.PaintWindow

procedureTEsCustomControl.PaintWindow(DC: HDC);var
  TempDC: HDC;
  UpdateRect: TRect;
  //---
  BufferDC: HDC;
  BufferBitMap: HBITMAP;
  Region: HRGN;
  SaveViewport: TPoint;
  BufferedThis: Boolean;
begin
  BufferBitMap := 0;
  Region := 0;
  BufferDC := 0;
  if GetClipBox(DC, UpdateRect) = ERROR then
    UpdateRect := ClientRect;
  BufferedThis := not BufferedChildren;
  // fix for designer selection
  BufferedThis := BufferedThis or (csDesigning in ComponentState);
  tryif BufferedThis thenbegin//------------------------------------------------------------------------------------------------// Duplicate code, see PaintHandler, Please sync this code!!!//------------------------------------------------------------------------------------------------// if control not double buffered then create or assign bufferifnot DoubleBuffered thenbegin
        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 bufferif BufferDC <> 0thenbegin// Using the cache if possibleif FIsCachedBuffer or FIsFullSizeBuffer thenbegin// Create cache if needif CacheBitmap = 0thenbegin
              BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
              // Assign to cache if needif FIsCachedBuffer then
                CacheBitmap := BufferBitMap;
            endelse
              BufferBitMap := CacheBitmap;
            // Assign region for minimal overdraw
            Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
            SelectClipRgn(BufferDC, Region);
          endelse// 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) pointifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin
            GetViewportOrgEx(BufferDC, SaveViewport);
            SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
          end;
        endelse
          BufferDC := DC;
      endelse
        BufferDC := DC;
    //------------------------------------------------------------------------------------------------endelse
      BufferDC := DC;
    ifnot(csOpaque in ControlStyle) thenif ParentBackground thenbeginif FIsCachedBackground thenbeginif CacheBackground = 0thenbegin
            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);
          ifnot 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);
        endelse
          DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False);endelseif (not DoubleBuffered or (DC <> 0)) thenifnot IsStyledClientControl(Self) then
            FillRect(BufferDC, ClientRect, Brush.Handle)
          elsebegin
            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;
  finallyif BufferedThis thenbegin//------------------------------------------------------------------------------------------------// Duplicate code, see PaintHandler, Please sync this code!!!//------------------------------------------------------------------------------------------------try// draw to windowifnot DoubleBuffered thenbeginifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin// [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);
          endelsebegin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finallyif BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0then
          DeleteObject(Region);
        // delete buffer, if needifnot FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------end;
  end;
end;

Buffering of nested TGraphicControls is implemented by the alternative PaintHandler method , in which buffering of all stages of component rendering, including drawing of TGraphicControls, takes place .

TEsCustomControl.PaintHandler

procedureTEsCustomControl.WMPaint(varMessage: TWMPaint);begin
  ControlState := ControlState + [csCustomPaint];
  // buffered childen aviable only for not DoubleBuffered controlsif BufferedChildren and (not FDoubleBuffered) andnot (csDesigning in ComponentState) then// fix for designer selectionbegin
    PaintHandler(Message)// My new PaintHandlerendelseinherited;
  ControlState := ControlState - [csCustomPaint];
end;
procedureTEsCustomControl.PaintHandler(varMessage: 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;
  tryif IsBeginPaint thenbegin
      DC := BeginPaint(Handle, PS);
      {$IFDEF VER230UP}if TStyleManager.IsCustomStyleActive andnot 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;
    endelsebegin
      DC := Message.DC;
      {$IFDEF VER230UP}if TStyleManager.IsCustomStyleActive andnot 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 bufferifnot DoubleBuffered thenbegin
      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 bufferif BufferDC <> 0thenbegin// Using the cache if possibleif FIsCachedBuffer or FIsFullSizeBuffer thenbegin// Create cache if needif CacheBitmap = 0thenbegin
            BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
            // Assign to cache if needif FIsCachedBuffer then
              CacheBitmap := BufferBitMap;
          endelse
            BufferBitMap := CacheBitmap;
          // Assign region for minimal overdraw
          Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
          SelectClipRgn(BufferDC, Region);
        endelse// 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) pointifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin
          GetViewportOrgEx(BufferDC, SaveViewport);
          SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
        end;
      endelse
        BufferDC := DC;
    endelse
      BufferDC := DC;
    //------------------------------------------------------------------------------------------------// DEFAULT HANDLER:Message.DC := BufferDC;
    inherited PaintHandler(Message);
  finallytry//------------------------------------------------------------------------------------------------// Duplicate code, see PaintWindow, Please sync this code!!!//------------------------------------------------------------------------------------------------try// draw to windowifnot DoubleBuffered thenbeginifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin// [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);
          endelsebegin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finallyif BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0then
          DeleteObject(Region);
        // delete buffer, if needifnot FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------finally// end paint, if needif IsBeginPaint then
        EndPaint(Handle, PS);
    end;
  end;
end;

The TEsCustomControl class has several useful properties and events:

  TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect)ofobject;/// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary>TEsCustomControl = class(TWinControl)
  ...
  publicconstructorCreate(AOwner: TComponent);override;
    destructorDestroy;override;
    procedureUpdateBackground(Repaint: Boolean);overload;
    procedureUpdateBackground;overload;
    // ------------------ Properties for published -------------------------------------------------property DoubleBuffered default False;
    {$IFDEF VER210UP}property ParentDoubleBuffered default False;
    {$ENDIF}// Painting for chidrens classesproperty OnPaint: TPaintEvent read FOnPaint write FOnPaint;
    property OnPainting: TPaintEvent read FOnPainting write FOnPainting;
    // BufferedChildrensproperty ParentBufferedChildren: Boolean read FParentBufferedChildren write SetParentBufferedChildren default True;
    property BufferedChildren: Boolean read FBufferedChildren write SetBufferedChildren stored IsBufferedChildrenStored;
    // External propproperty IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False;
    property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False;
    property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
    property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False;
    property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write SetIsFullSizeBuffer default False;
  end;

An interesting feature may be IsDrawHelper that paints a comfortable frame in DesignTime .

To create your non-flickering component, all you have to do is inherit from TEsCustomControl , as if you were making an inheritor from TCustomControl , and declare the properties you need as published .

TEsCustomControl gives you complete control over the buffering and rendering process, and has proven its reliability in many projects and components.

For example, consider the TEsLayout component - a transparent Layout with the ability to buffer TGraphicControls embedded in it :
https://github.com/errorcalc/FreeEsVclComponents/blob/master/Source/ES.Layouts.pas

And under the spoiler

{******************************************************************************}{                            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;
interfaceuses
  Winapi.Messages, Vcl.Controls, System.Classes, System.Types, Vcl.Graphics, ES.BaseControls,
  ES.CfxClasses;
typeTEsCustomLayout = class(TEsBaseLayout)
  private
    FLocked: Boolean;
    procedureCMIsToolControl(varMessage: TMessage);message CM_ISTOOLCONTROL;
  protectedprocedureCreateParams(var Params: TCreateParams);override;
    property UseDockManager default True;
  publicconstructorCreate(AOwner: TComponent);override;
    property Color default clBtnFace;
    property DockManager;
    property Locked: Boolean read FLocked write FLocked default False;
  end;
  TEsLayout = class(TEsCustomLayout)
  publishedproperty Align;
    property Anchors;
    property AutoSize;
    property BiDiMode;
    property BorderWidth;
    property BufferedChildren;// TEsCustomControlproperty Color;
    property Constraints;
    property Ctl3D;
    property UseDockManager;
    property DockSite;
    property DoubleBuffered;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property IsCachedBuffer;// TEsCustomControlproperty IsCachedBackground;// TEsCustomControlproperty IsDrawHelper;// TEsCustomControlproperty IsOpaque;// TEsCustomControlproperty IsFullSizeBuffer;// TEsCustomControlproperty Locked;
    property Padding;
    property ParentBiDiMode;
    property ParentBackground;
    property ParentBufferedChildren;// TEsCustomControlproperty 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;// TEsCustomControlproperty OnPainting;// TEsCustomControlproperty OnStartDock;
    property OnStartDrag;
    property OnUnDock;
  end;
  TEsPanel = class(TEsLayout)
  private
    FFrameWidth: TFrameWidth;
    FFrameColor: TColor;
    FFrameStyle: TFrameStyle;
    procedureSetFrameColor(const Value: TColor);procedureSetFrameStyle(const Value: TFrameStyle);procedureSetFrameWidth(const Value: TFrameWidth);protectedprocedurePaint;override;
    procedureAdjustClientRect(var Rect: TRect);override;
  publicconstructorCreate(AOwner: TComponent);override;
  publishedproperty BevelKind;
    property BevelInner;
    property BevelOuter;
    property FrameStyle: TFrameStyle read FFrameStyle write SetFrameStyle default TExFrameStyle.Raised;
    property FrameColor: TColor read FFrameColor write SetFrameColor default clBtnShadow;
    property FrameWidth: TFrameWidth read FFrameWidth write SetFrameWidth default1;
  end;
implementationuses
  ES.ExGraphics, ES.Utils, Vcl.Themes;
procedureTEsCustomLayout.CMIsToolControl(varMessage: TMessage);beginifnot FLocked thenMessage.Result := 1;
end;
constructorTEsCustomLayout.Create(AOwner: TComponent);begininherited Create(AOwner);
  ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
    csSetCaption, csParentBackground, csDoubleClicks, csReplicatable, csPannable, csGestures];
  Width := 185;
  Height := 41;
  UseDockManager := True;
end;
procedureTEsCustomLayout.CreateParams(var Params: TCreateParams);begininherited CreateParams(Params);
  // nope nowend;
{ TEsPanel }procedureTEsPanel.AdjustClientRect(var Rect: TRect);begininherited;
  if FrameStyle <> TExFrameStyle.None thenbegin
    Rect.Inflate(-GetFrameWidth(FrameStyle, FrameWidth), -GetFrameWidth(FrameStyle, FrameWidth));
  end;
end;
constructorTEsPanel.Create(AOwner: TComponent);begininherited;
  FFrameColor := clBtnShadow;
  FFrameWidth := 1;
  FFrameStyle := TExFrameStyle.Raised;
end;
procedureTEsPanel.Paint;beginif (csDesigning in ComponentState) and IsDrawHelper then
    DrawControlHelper(Self, [hoPadding, hoClientRect], GetFrameWidth(FrameStyle, FrameWidth));
  if FrameStyle <> TExFrameStyle.None thenif IsStyledBorderControl(Self) then
      DrawFrame(Canvas, ClientRect, FrameStyle, FrameWidth, StyleServices.GetSystemColor(FrameColor),
        StyleServices.GetSystemColor(clBtnHighlight), StyleServices.GetSystemColor(clBtnShadow))
    else
      DrawFrame(Canvas, ClientRect, FrameStyle, FrameWidth, FrameColor, clBtnHighlight, clBtnShadow);
end;
procedureTEsPanel.SetFrameColor(const Value: TColor);beginif FFrameColor <> Value thenbegin
    FFrameColor := Value;
    Invalidate;
  end;
end;
procedureTEsPanel.SetFrameStyle(const Value: TFrameStyle);beginif FFrameStyle <> Value thenbegin
    FFrameStyle := Value;
    Realign;
    Invalidate;
  end;
end;
procedureTEsPanel.SetFrameWidth(const Value: TFrameWidth);beginif FFrameWidth <> Value thenbegin
    FFrameWidth := Value;
    Realign;
    Invalidate;
  end;
end;
end.

The source code for the module containing TEsCustomControl and version- Layout s TEsBaseLayout available here:
https://github.com/errorcalc/FreeEsVclComponents/blob/master/Source/ES.BaseControls.pas

And under the spoiler

{******************************************************************************}{                       EsVclComponents/EsVclCore v3.0                         }{                           errorsoft(c) 2009-2018                             }{                                                                              }{                     More beautiful things: errorsoft.org                     }{                                                                              }{           errorsoft@mail.ru | vk.com/errorsoft | github.com/errorcalc        }{              errorsoft@protonmail.ch | habrahabr.ru/user/error1024           }{                                                                              }{         Open this on github: github.com/errorcalc/FreeEsVclComponents        }{                                                                              }{ You can order developing vcl/fmx components, please submit requests to mail. }{ �� ������ �������� ���������� VCL/FMX ���������� �� �����.                   }{******************************************************************************}{
  This is the base unit, which must remain Delphi 7 support, and it should not
  be dependent on any other units!
}unit ES.BaseControls;
{$IF CompilerVersion >= 18}{$DEFINE VER180UP}{$IFEND}{$IF CompilerVersion >= 21}{$DEFINE VER210UP}{$IFEND}{$IF CompilerVersion >= 23}{$DEFINE VER230UP}{$IFEND}{$IF CompilerVersion >= 24}{$DEFINE VER240UP}{$IFEND}// see function CalcClientRect{$define FAST_CALC_CLIENTRECT}// see TEsBaseLayout.ContentRect{$define TEST_CONTROL_CONTENT_RECT}interfaceuses
  WinApi.Windows, System.Types, System.Classes, Vcl.Controls,
  Vcl.Graphics, {$IFDEF VER230UP}Vcl.Themes,{$ENDIF} WinApi.Messages, WinApi.Uxtheme, Vcl.Forms;
const
  CM_ESBASE = CM_BASE + $0800;
  CM_PARENT_BUFFEREDCHILDRENS_CHANGED = CM_ESBASE + 1;
  EsVclCoreVersion = 3.0;
type
  THelperOption = (hoPadding, hoBorder, hoClientRect);
  THelperOptions = setof THelperOption;
  TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect)ofobject;/// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary>TEsCustomControl = class(TWinControl)
  private// anti flicker and transparent magic
    FCanvas: TCanvas;
    CacheBitmap: HBITMAP;// Cache for buffer BitMap
    CacheBackground: HBITMAP;// Cache for background BitMap
    FIsCachedBuffer: Boolean;
    FIsCachedBackground: Boolean;
    FBufferedChildren: Boolean;
    FParentBufferedChildren: Boolean;
    FIsFullSizeBuffer: Boolean;
    // paint events
    FOnPaint: TPaintEvent;
    FOnPainting: TPaintEvent;
    // draw helper
    FIsDrawHelper: Boolean;
    // paintprocedureSetIsCachedBuffer(Value: Boolean);procedureSetIsCachedBackground(Value: Boolean);procedureSetIsDrawHelper(const Value: Boolean);procedureSetIsOpaque(const Value: Boolean);functionGetIsOpaque: Boolean;
    procedureSetBufferedChildren(const Value: Boolean);procedureSetParentBufferedChildren(const Value: Boolean);functionGetTransparent: Boolean;
    procedureSetTransparent(const Value: Boolean);functionIsBufferedChildrenStored: Boolean;
    // handle messagesprocedureWMPaint(varMessage: TWMPaint);message WM_PAINT;
    procedureWMEraseBkgnd(varMessage: TWMEraseBkgnd);message WM_ERASEBKGND;
    procedureWMWindowPosChanged(varMessage: TWMWindowPosChanged);message WM_WINDOWPOSCHANGED;
    procedureWMSize(varMessage: TWMSize);message WM_SIZE;
    procedureCMParentBufferedChildrensChanged(varMessage: TMessage);message CM_PARENT_BUFFEREDCHILDRENS_CHANGED;
    procedureDrawBackgroundForOpaqueControls(DC: HDC);// intercept mouse// procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;// otherprocedureCMTextChanged(varMessage: TMessage);message CM_TEXTCHANGED;
    procedureWMTextChanges(varMessage: TMessage);message WM_SETTEXT;
    // fixprocedureFixBufferedChildren(Reader: TReader);procedureFixParentBufferedChildren(Reader: TReader);procedureSetIsFullSizeBuffer(const Value: Boolean);protected// fixprocedureDefineProperties(Filer: TFiler);override;
    // paintproperty Canvas: TCanvas read FCanvas;
    procedureDeleteCache;{$IFDEF VER210UP}inline;{$ENDIF}procedurePaint;virtual;
    procedurePaintWindow(DC: HDC);override;
    procedurePaintHandler(varMessage: TWMPaint);procedureDrawBackground(DC: HDC);virtual;
    // otherprocedureUpdateText;dynamic;
    //property ParentBackground default True;
    property Transparent: Boolean read GetTransparent write SetTransparent default True;// analog of ParentBackgroundpublicconstructorCreate(AOwner: TComponent);override;
    destructorDestroy;override;
    procedureUpdateBackground(Repaint: Boolean);overload;
    procedureUpdateBackground;overload;
    // ------------------ Properties for published -------------------------------------------------property DoubleBuffered default False;
    {$IFDEF VER210UP}property ParentDoubleBuffered default False;
    {$ENDIF}// Painting for chidrens classesproperty OnPaint: TPaintEvent read FOnPaint write FOnPaint;
    property OnPainting: TPaintEvent read FOnPainting write FOnPainting;
    // BufferedChildrensproperty ParentBufferedChildren: Boolean read FParentBufferedChildren write SetParentBufferedChildren default True;
    property BufferedChildren: Boolean read FBufferedChildren write SetBufferedChildren stored IsBufferedChildrenStored;
    // External propproperty IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False;
    property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False;
    property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
    property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False;
    property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write SetIsFullSizeBuffer default False;
  end;
  {$IFDEF VER180UP}
  TContentMargins = recordtype
    TMarginSize = 0..MaxInt;
  private
    Left: TMarginSize;
    Top: TMarginSize;
    Right: TMarginSize;
    Bottom: TMarginSize;
  publicfunctionWidth: TMarginSize;
    functionHeight: TMarginSize;
    procedureInflate(DX, DY: Integer);overload;
    procedureInflate(DLeft, DTop, DRight, DBottom: Integer);overload;
    procedureReset;constructorCreate(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;
    procedureSetBorderWidth(const Value: TBorderWidth);protectedprocedureAlignControls(AControl: TControl; var Rect: TRect);override;
    procedureAdjustClientRect(var Rect: TRect);override;
    procedurePaint;override;
    // newprocedureCalcContentMargins(var Margins: TContentMargins);virtual;
  publicconstructorCreate(AOwner: TComponent);override;
    functionContentRect: TRect; virtual;
    functionContentMargins: TContentMargins; inline;
    property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default0;
    property BufferedChildren default True;
  end;
  /// <summary> The GraphicControl, supports Padding and IsDrawHelper property </summary>TEsGraphicControl = class(TGraphicControl)
  private
    FPadding: TPadding;
    FIsDrawHelper: Boolean;
    functionGetPadding: TPadding;
    procedureSetPadding(const Value: TPadding);procedurePaddingChange(Sender: TObject);procedureSetIsDrawHelper(const Value: Boolean);protectedprocedurePaint;override;
    functionHasPadding: Boolean;
    // newprocedureCalcContentMargins(var Margins: TContentMargins);virtual;
  publicdestructorDestroy;override;
    property Padding: TPadding read GetPadding write SetPadding;
    functionContentRect: TRect; virtual;
    functionContentMargins: TContentMargins; inline;
    property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
  end;
  procedureDrawControlHelper(Control: TControl; Options: THelperOptions; FrameWidth: Integer = 0);overload;
  procedureDrawControlHelper(Canvas: TCanvas; Rect: TRect; BorderWidth: TBorderWidth;
    Padding: TPadding; Options: THelperOptions);overload;
  {$ENDIF}functionCalcClientRect(Control: TControl): TRect;
  procedureDrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);implementationuses
  System.SysUtils, System.TypInfo;
typeTOpenCtrl = class(TWinControl)
  publicproperty BorderWidth;
  end;
// Old delphi support{$IFNDEF VER210UP}functionRectWidth(const Rect: TRect): Integer;
begin
  Result := Rect.Right - Rect.Left;
end;
functionRectHeight(const Rect: TRect): Integer;
begin
  Result := Rect.Bottom - Rect.Top;
end;
{$ENDIF}{$IFDEF VER210UP}{$REGION 'DrawControlHelper'}procedureDrawControlHelper(Canvas: TCanvas; Rect: TRect; BorderWidth: TBorderWidth;
  Padding: TPadding; Options: THelperOptions);procedureLine(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;
  tryif Canvas.Handle = 0thenExit;
    // 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 Helperif THelperOption.hoClientRect in Options thenbegin
      SaveBk := SetBkColor(Canvas.Handle, RGB(127,255,255));
      DrawFocusRect(Canvas.Handle, Rect);
      SetBkColor(Canvas.Handle, SaveBk);
    end;
    // Border Helperif THelperOption.hoBorder in Options thenbeginif (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 Helperif THelperOption.hoPadding in Options thenbeginif (BorderWidth + Padding.Top < RectHeight(Rect) - BorderWidth - Padding.Bottom) and
         (BorderWidth + Padding.Left < RectWidth(Rect) - BorderWidth - Padding.Right) thenbegin
        Canvas.Pen.Style := psDot;
        if Padding.Left <> 0then
          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 <> 0then
          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 <> 0then
          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 <> 0then
          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;
procedureDrawControlHelper(Control: TControl; Options: THelperOptions; FrameWidth: Integer = 0);var
  Canvas: TCanvas;
  Padding: TPadding;
  BorderWidth: Integer;
  MyCanvas: Boolean;
  R: TRect;
begin
  MyCanvas := False;
  Canvas := nil;
  Padding := nil;
  BorderWidth := 0;
  // if win controlif Control is TWinControl thenbegin
    TOpenCtrl(Control).AdjustClientRect(R);
    // get padding
    Padding := TWinControl(Control).Padding;
    // get canvasif Control is TEsCustomControl then
      Canvas := TEsCustomControl(Control).Canvas
    elsebegin
      MyCanvas := True;
      Canvas := TControlCanvas.Create;
      TControlCanvas(Canvas).Control := Control;
    end;
    // get border widthif Control is TEsBaseLayout then
      BorderWidth := TEsBaseLayout(Control).BorderWidth
    else
      BorderWidth := TOpenCtrl(Control).BorderWidth;
  endelseif Control is TGraphicControl thenbegin// get canvas
    Canvas := TEsGraphicControl(Control).Canvas;
    if Control is TEsGraphicControl then
      Padding := TEsGraphicControl(Control).Padding;
  end;
  try
    R := Control.ClientRect;
    R.Inflate(-FrameWidth, -FrameWidth);
    DrawControlHelper(Canvas, R, BorderWidth, Padding, Options);
  finallyif MyCanvas then
      Canvas.Free;
  end;
end;
{$ENDREGION}{$ENDIF}functionIsStyledClientControl(Control: TControl): Boolean;
begin
  Result := False;
  {$IFDEF VER230UP}if Control = nilthenExit;
  if StyleServices.Enabled thenbegin
    Result := {$ifdef VER240UP}(seClient in Control.StyleElements) and{$endif}
      TStyleManager.IsCustomStyleActive;
  end;
  {$ENDIF}end;
functionCalcClientRect(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 areaifnot (Control is TWinControl) thenExit;
  // Fast method not work for controls not having Handleifnot TWinControl(Control).Handle <> 0then
    IsFast := False;
  if IsFast thenbegin
    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;
  endelsebegin
    Control.Perform(WM_NCCALCSIZE, 0, LParam(@Result));
  end;
end;
procedureDrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);var
  ClientRect: TRect;
  P: TPoint;
  SaveIndex: Integer;
beginif Control.Parent = nilthenExit;
  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) thenbegin
    ClientRect := CalcClientRect(Control);
    SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil);
  endelse
    SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil);
  IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
  Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
  Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT);
  RestoreDC(DC, SaveIndex);
  if InvalidateParent thenifnot (Control.Parent is TCustomControl) andnot (Control.Parent is TCustomForm) andnot (csDesigning in Control.ComponentState)andnot (Control.Parent is TEsCustomControl) thenbegin
      Control.Parent.Invalidate;
    end;
  SetViewportOrgEx(DC, P.X, P.Y, nil);
end;
procedureBitmapDeleteAndNil(var Bitmap: HBITMAP);{$IFDEF VER210UP}inline;{$ENDIF}beginif Bitmap <> 0thenbegin
    DeleteObject(Bitmap);
    Bitmap := 0;
  end;
end;
procedureTEsCustomControl.CMParentBufferedChildrensChanged(varMessage: TMessage);beginif FParentBufferedChildren thenbeginif Parent <> nilthenbeginif Parent is TEsCustomControl then
        BufferedChildren := TEsCustomControl(Parent).BufferedChildren
      else
        BufferedChildren := False;
    end;
    FParentBufferedChildren := True;
  end;
end;
procedureTEsCustomControl.CMTextChanged(varMessage: TMessage);begininherited;
  UpdateText;
end;
procedureTEsCustomControl.WMTextChanges(varMessage: TMessage);beginInherited;
  UpdateText;
end;
constructorTEsCustomControl.Create(AOwner: TComponent);begininherited Create(AOwner);
  // init
  ControlStyle := ControlStyle - [csOpaque] + [csParentBackground];
  {$IFDEF VER210UP}
  ParentDoubleBuffered := False;
  {$ENDIF}
  CacheBitmap := 0;
  CacheBackground := 0;
  // canvas
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  // new props
  FParentBufferedChildren := True;
  FBufferedChildren := False;
  FIsCachedBuffer := False;
  FIsCachedBackground := False;
  FIsFullSizeBuffer := False;
  FIsDrawHelper := False;
end;
// temp fixprocedureTEsCustomControl.DefineProperties(Filer: TFiler);begininherited;
  Filer.DefineProperty('BufferedChildrens', FixBufferedChildren, nil, False);
  Filer.DefineProperty('ParentBufferedChildrens', FixParentBufferedChildren, nil, False);
end;
// okprocedureTEsCustomControl.DeleteCache;begin
  BitmapDeleteAndNil(CacheBitmap);
  BitmapDeleteAndNil(CacheBackground);
end;
destructorTEsCustomControl.Destroy;begin
  FCanvas.Free;
  DeleteCache;
  inherited;
end;
procedureTEsCustomControl.DrawBackground(DC: HDC);begin
  DrawParentImage(Self, DC, False);
end;
// hack for bad graphic controlsprocedureTEsCustomControl.DrawBackgroundForOpaqueControls(DC: HDC);var
  i: integer;
  Control: TControl;
  Prop: Pointer;
beginfor i := 0to ControlCount - 1dobegin
    Control := Controls[i];
    if (Control is TGraphicControl) and (csOpaque in Control.ControlStyle) and Control.Visible and
       (not (csDesigning in ComponentState) ornot (csNoDesignVisible in ControlStyle)
       {$IFDEF VER210UP}ornot (csDesignerHide in Control.ControlState){$ENDIF})
    thenbegin// 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 <> nilthenbegin
        Prop := GetPropInfo(Control.ClassInfo, 'Color');
        if Prop = nilthen
          FillRect(DC, Rect(Control.Left, Control.Top, Control.Left + Control.Width, Control.Top + Control.Height), Brush.Handle);
      end;
    end;
  end;
end;
(*procedure TEsCustomControl.EndCachedBackground;
begin
  FIsCachedBackground := StoredCachedBackground;
end;
procedure TEsCustomControl.EndCachedBuffer;
begin
  FIsCachedBuffer := StoredCachedBuffer;
end;*)// temp fixprocedureTEsCustomControl.FixBufferedChildren(Reader: TReader);begin
  BufferedChildren := Reader.ReadBoolean;
end;
// temp fixprocedureTEsCustomControl.FixParentBufferedChildren(Reader: TReader);begin
  ParentBufferedChildren := Reader.ReadBoolean;
end;
functionTEsCustomControl.GetIsOpaque: Boolean;
begin
  Result := csOpaque in ControlStyle;
end;
functionTEsCustomControl.GetTransparent: Boolean;
begin
  Result := ParentBackground;
end;
procedureTEsCustomControl.Paint;var
  SaveBk: TColor;
begin// for Design timeif IsDrawHelper and(csDesigning in ComponentState) thenbegin
    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! }procedureTEsCustomControl.PaintHandler(varMessage: 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;
  tryif IsBeginPaint thenbegin
      DC := BeginPaint(Handle, PS);
      {$IFDEF VER230UP}if TStyleManager.IsCustomStyleActive andnot 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;
    endelsebegin
      DC := Message.DC;
      {$IFDEF VER230UP}if TStyleManager.IsCustomStyleActive andnot 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 bufferifnot DoubleBuffered thenbegin
      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 bufferif BufferDC <> 0thenbegin// Using the cache if possibleif FIsCachedBuffer or FIsFullSizeBuffer thenbegin// Create cache if needif CacheBitmap = 0thenbegin
            BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
            // Assign to cache if needif FIsCachedBuffer then
              CacheBitmap := BufferBitMap;
          endelse
            BufferBitMap := CacheBitmap;
          // Assign region for minimal overdraw
          Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
          SelectClipRgn(BufferDC, Region);
        endelse// 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) pointifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin
          GetViewportOrgEx(BufferDC, SaveViewport);
          SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
        end;
      endelse
        BufferDC := DC;
    endelse
      BufferDC := DC;
    //------------------------------------------------------------------------------------------------// DEFAULT HANDLER:Message.DC := BufferDC;
    inherited PaintHandler(Message);
  finallytry//------------------------------------------------------------------------------------------------// Duplicate code, see PaintWindow, Please sync this code!!!//------------------------------------------------------------------------------------------------try// draw to windowifnot DoubleBuffered thenbeginifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin// [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);
          endelsebegin
            BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
              UpdateRect.Left, UpdateRect.Top, SRCCOPY);
          end;
        end;
      finallyif BufferDC <> DC then
          DeleteObject(BufferDC);
        if Region <> 0then
          DeleteObject(Region);
        // delete buffer, if needifnot FIsCachedBuffer and (BufferBitMap <> 0) then
          DeleteObject(BufferBitMap);
      end;
      //------------------------------------------------------------------------------------------------finally// end paint, if needif IsBeginPaint then
        EndPaint(Handle, PS);
    end;
  end;
end;
{ TODO -cMAJOR : 22.02.2013:
 See: PaintHandler,
 need eliminate duplication of code! }procedureTEsCustomControl.PaintWindow(DC: HDC);var
  TempDC: HDC;
  UpdateRect: TRect;
  //---
  BufferDC: HDC;
  BufferBitMap: HBITMAP;
  Region: HRGN;
  SaveViewport: TPoint;
  BufferedThis: Boolean;
begin
  BufferBitMap := 0;
  Region := 0;
  BufferDC := 0;
  if GetClipBox(DC, UpdateRect) = ERROR then
    UpdateRect := ClientRect;
  BufferedThis := not BufferedChildren;
  // fix for designer selection
  BufferedThis := BufferedThis or (csDesigning in ComponentState);
  tryif BufferedThis thenbegin//------------------------------------------------------------------------------------------------// Duplicate code, see PaintHandler, Please sync this code!!!//------------------------------------------------------------------------------------------------// if control not double buffered then create or assign bufferifnot DoubleBuffered thenbegin
        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 bufferif BufferDC <> 0thenbegin// Using the cache if possibleif FIsCachedBuffer or FIsFullSizeBuffer thenbegin// Create cache if needif CacheBitmap = 0thenbegin
              BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
              // Assign to cache if needif FIsCachedBuffer then
                CacheBitmap := BufferBitMap;
            endelse
              BufferBitMap := CacheBitmap;
            // Assign region for minimal overdraw
            Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
            SelectClipRgn(BufferDC, Region);
          endelse// 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) pointifnot(FIsCachedBuffer or FIsFullSizeBuffer) thenbegin
            GetViewportOrgEx(BufferDC, SaveViewport);
            SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
          end;
        endelse
          BufferDC := DC;
      endelse
        BufferDC := DC;
    //------------------------------------------------------------------------------------------------endelse
      BufferDC := DC;
    ifnot(csOpaque in ControlStyle) thenif ParentBackground thenbeginif FIsCachedBackground thenbeginif CacheBackground = 0thenbegin
            Temp

VCL, get rid of flicker, once and for all

Also popular now: