Delphi и C++Builder разработчики, использующие VCL не по наслышке знают о вездесущей проблеме мерцания контролов. Мерцание происходит при перерисовке, вследствие того, что сначала отрисовывается фон компонента, и только потом сам компонент.
И если в случае с наследниками от TWinControl частичным решением проблемы является установка свойства DoubleBuffered в True, что заставляет контрол отрисовываться в буфере (однако DoubleBuffered работает тоже не идеально, к прим.: контрол перестает быть прозрачным), то в случае с TGraphicControl решение с DoubleBuffered просто невозможно, из-за отсутствия у TGraphicControl окна, установка же DoubleBuffered в True у родителя не помогает, из-за того что отрисовка вложенных TGraphicControl-ов происходит уже после прорисовки родителя в буфере.
Обычно остается только одно — смириться с мерцанием, и максимально упростить отрисовку для минимизации эффекта, или использовать по возможности исключительно TWinControl-ы, что не всегда возможно и удобно.
Однажды намучившись с мерцанием, я не выдержал и решил решить эту проблему, раз и навсегда!
Как мне удалось решить проблему?
Заранее извиняюсь за некоторую сумбурность подачи, и недосказанность, описывать подобные вещи довольно сложно, однако поделиться с сообществом хочется.
Был разработан класс TEsCustomControl = class(TWinControl), который осуществляет альтернативную буферизацию (при DoubleBuffered = False, иначе используется родная буферизация VCL).
Класс имеет свойство BufferedChildren, при активации которого отрисовка вложенных TGraphicControl-ов происходит в буфере, что полностью избавляет от мерцания.
К счастью в VCL нужные методы отрисовки объявлены не как private, что и позволило реализовать полную буферизацию.
Для того чтобы компонент выглядел прозрачным, необходимо отрисовать на нем фон нижележащего компонента, что осуществляется с помощью процедуры DrawParentImage.
procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False); var ClientRect: TRect; P: TPoint; SaveIndex: Integer; begin if Control.Parent = nil then Exit; SaveIndex := SaveDC(DC); GetViewportOrgEx(DC, P); // if control has non client border then need additional offset viewport ClientRect := Control.ClientRect; if (ClientRect.Right <> Control.Width) or (ClientRect.Bottom <> Control.Height) then begin ClientRect := CalcClientRect(Control); SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil); end else SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil); IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight); Control.Parent.Perform(WM_ERASEBKGND, DC, 0); Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT); RestoreDC(DC, SaveIndex); if InvalidateParent then if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and not (csDesigning in Control.ComponentState)and not (Control.Parent is TEsCustomControl) then begin Control.Parent.Invalidate; end; SetViewportOrgEx(DC, P.X, P.Y, nil); end;
Буферизация происходит за счет того что компонент в переопределенном методе PaintWindow отрисовывается не непосредственно на предоставленный хендл, а на временный (или нет в зависимости от свойства IsCachedBuffer) HBITMAP, и уже после полной отрисовки копируется функцией BitBlt.
(Довольно много кода, из-за многих частных случаев)
TEsCustomControl.PaintWindow
procedure TEsCustomControl.PaintWindow(DC: HDC); var TempDC: HDC; UpdateRect: TRect; //--- BufferDC: HDC; BufferBitMap: HBITMAP; Region: HRGN; SaveViewport: TPoint; BufferedThis: Boolean; begin BufferBitMap := 0; Region := 0; BufferDC := 0; if GetClipBox(DC, UpdateRect) = ERROR then UpdateRect := ClientRect; BufferedThis := not BufferedChildren; // fix for designer selection BufferedThis := BufferedThis or (csDesigning in ComponentState); try if BufferedThis then begin //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintHandler, Please sync this code!!! //------------------------------------------------------------------------------------------------ // if control not double buffered then create or assign buffer if not DoubleBuffered then begin BufferDC := CreateCompatibleDC(DC); // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer): // return <> 0 => need to double buffer || return = 0 => no need to double buffer if BufferDC <> 0 then begin // Using the cache if possible if FIsCachedBuffer or FIsFullSizeBuffer then begin // Create cache if need if CacheBitmap = 0 then begin BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight); // Assign to cache if need if FIsCachedBuffer then CacheBitmap := BufferBitMap; end else BufferBitMap := CacheBitmap; // Assign region for minimal overdraw Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height); SelectClipRgn(BufferDC, Region); end else // Create buffer BufferBitMap := CreateCompatibleBitmap(DC, RectWidth(UpdateRect), RectHeight(UpdateRect)); // Select buffer bitmap SelectObject(BufferDC, BufferBitMap); // [change coord], if need // Moving update region to the (0,0) point if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin GetViewportOrgEx(BufferDC, SaveViewport); SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil); end; end else BufferDC := DC; end else BufferDC := DC; //------------------------------------------------------------------------------------------------ end else BufferDC := DC; if not(csOpaque in ControlStyle) then if ParentBackground then begin if FIsCachedBackground then begin if CacheBackground = 0 then begin TempDC := CreateCompatibleDC(DC); CacheBackground := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight); SelectObject(TempDC, CacheBackground); DrawBackground(TempDC); //DrawParentImage(Self, TempDC, False); DeleteDC(TempDC); end; TempDC := CreateCompatibleDC(BufferDC); SelectObject(TempDC, CacheBackground); if not FIsCachedBuffer then BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY) else BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY); DeleteDC(TempDC); end else DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False); end else if (not DoubleBuffered or (DC <> 0)) then if not IsStyledClientControl(Self) then FillRect(BufferDC, ClientRect, Brush.Handle) else begin SetDCBrushColor(BufferDC, ColorToRGB({$ifdef VER230UP}StyleServices.GetSystemColor(Color){$else}Color{$endif})); FillRect(BufferDC, ClientRect, GetStockObject(DC_BRUSH)); end; FCanvas.Lock; try Canvas.Handle := BufferDC; TControlCanvas(Canvas).UpdateTextFlags; if Assigned(FOnPainting) then FOnPainting(Self, Canvas, ClientRect); Paint; if Assigned(FOnPaint) then FOnPaint(Self, Canvas, ClientRect); finally FCanvas.Handle := 0; FCanvas.Unlock; end; finally if BufferedThis then begin //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintHandler, Please sync this code!!! //------------------------------------------------------------------------------------------------ try // draw to window if not DoubleBuffered then begin if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin // [restore coord], if need SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil); BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY); end else begin BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY); end; end; finally if BufferDC <> DC then DeleteObject(BufferDC); if Region <> 0 then DeleteObject(Region); // delete buffer, if need if not FIsCachedBuffer and (BufferBitMap <> 0) then DeleteObject(BufferBitMap); end; //------------------------------------------------------------------------------------------------ end; end; end;
Буферизация вложенных TGraphicControl-ов реализована альтернативным методом PaintHandler, в котором происходит буферизация всех этапов прорисовки компонента, в том числе и отрисовки TGraphicControl-ов.
TEsCustomControl.PaintHandler
procedure TEsCustomControl.WMPaint(var Message: TWMPaint); begin ControlState := ControlState + [csCustomPaint]; // buffered childen aviable only for not DoubleBuffered controls if BufferedChildren and (not FDoubleBuffered) and not (csDesigning in ComponentState) then // fix for designer selection begin PaintHandler(Message)// My new PaintHandler end else inherited; ControlState := ControlState - [csCustomPaint]; end; procedure TEsCustomControl.PaintHandler(var Message: TWMPaint); var PS: TPaintStruct; BufferDC: HDC; BufferBitMap: HBITMAP; UpdateRect: TRect; SaveViewport: TPoint; Region: HRGN; DC: HDC; IsBeginPaint: Boolean; begin BufferBitMap := 0; BufferDC := 0; DC := 0; Region := 0; IsBeginPaint := Message.DC = 0; try if IsBeginPaint then begin DC := BeginPaint(Handle, PS); {$IFDEF VER230UP} if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then UpdateRect := ClientRect // I had to use a crutch to ClientRect, due to the fact that // VCL.Styles.TCustomStyle.DoDrawParentBackground NOT use relative coordinates, // ie ignores SetViewportOrgEx! // This function uses ClientToScreen and ScreenToClient for coordinates calculation! else {$endif} UpdateRect := PS.rcPaint; end else begin DC := Message.DC; {$IFDEF VER230UP} if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then UpdateRect := ClientRect else {$endif} if GetClipBox(DC, UpdateRect) = ERROR then UpdateRect := ClientRect; end; //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintWindow, Please sync this code!!! //------------------------------------------------------------------------------------------------ // if control not double buffered then create or assign buffer if not DoubleBuffered then begin BufferDC := CreateCompatibleDC(DC); // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer): // return <> 0 => need to double buffer || return = 0 => no need to double buffer if BufferDC <> 0 then begin // Using the cache if possible if FIsCachedBuffer or FIsFullSizeBuffer then begin // Create cache if need if CacheBitmap = 0 then begin BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight); // Assign to cache if need if FIsCachedBuffer then CacheBitmap := BufferBitMap; end else BufferBitMap := CacheBitmap; // Assign region for minimal overdraw Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height); SelectClipRgn(BufferDC, Region); end else // Create buffer BufferBitMap := CreateCompatibleBitmap(DC, UpdateRect.Right - UpdateRect.Left, UpdateRect.Bottom - UpdateRect.Top); // Select buffer bitmap SelectObject(BufferDC, BufferBitMap); // [change coord], if need // Moving update region to the (0,0) point if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin GetViewportOrgEx(BufferDC, SaveViewport); SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil); end; end else BufferDC := DC; end else BufferDC := DC; //------------------------------------------------------------------------------------------------ // DEFAULT HANDLER: Message.DC := BufferDC; inherited PaintHandler(Message); finally try //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintWindow, Please sync this code!!! //------------------------------------------------------------------------------------------------ try // draw to window if not DoubleBuffered then begin if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin // [restore coord], if need SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil); BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY); end else begin BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY); end; end; finally if BufferDC <> DC then DeleteObject(BufferDC); if Region <> 0 then DeleteObject(Region); // delete buffer, if need if not FIsCachedBuffer and (BufferBitMap <> 0) then DeleteObject(BufferBitMap); end; //------------------------------------------------------------------------------------------------ finally // end paint, if need if IsBeginPaint then EndPaint(Handle, PS); end; end; end;
Класс TEsCustomControl имеет несколько полезных свойств и событий:
TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect) of object; /// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary> TEsCustomControl = class(TWinControl) ... public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure UpdateBackground(Repaint: Boolean); overload; procedure UpdateBackground; overload; // ------------------ Properties for published ------------------------------------------------- property DoubleBuffered default False; {$IFDEF VER210UP} property ParentDoubleBuffered default False; {$ENDIF} // Painting for chidrens classes property OnPaint: TPaintEvent read FOnPaint write FOnPaint; property OnPainting: TPaintEvent read FOnPainting write FOnPainting; // BufferedChildrens property ParentBufferedChildren: Boolean read FParentBufferedChildren write SetParentBufferedChildren default True; property BufferedChildren: Boolean read FBufferedChildren write SetBufferedChildren stored IsBufferedChildrenStored; // External prop property IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False; property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False; property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False; property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False; property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write SetIsFullSizeBuffer default False; end;
Интересным может оказаться свойство IsDrawHelper рисующее удобную рамку в DesignTime.
Для создания своего не мерцающего компонента вам достаточно унаследоваться от TEsCustomControl, как если бы вы делали наследника от TCustomControl, и объявить нужные вам свойства как published.
TEsCustomControl дает полное управление процессом буферизации и отрисовки, и доказал свою надежность во многих проектах и компонентах.
Для примера можно рассмотреть компонент TEsLayout — прозрачный Layout с возможностью буферизации вложенных в него TGraphicControl-ов:
https://github.com/errorcalc/FreeEsVclComponents/blob/master/Source/ES.Layouts.pas
И под спойлером
{******************************************************************************} { EsVclComponents v2.0 } { ErrorSoft(c) 2009-2016 } { } { More beautiful things: errorsoft.org } { } { errorsoft@mail.ru | vk.com/errorsoft | github.com/errorcalc } { errorsoft@protonmail.ch | habrahabr.ru/user/error1024 } { } { Open this on github: github.com/errorcalc/FreeEsVclComponents } { } { You can order developing vcl/fmx components, please submit requests to mail. } { Вы можете заказать разработку VCL/FMX компонента на заказ. } {******************************************************************************} unit ES.Layouts; interface uses Winapi.Messages, Vcl.Controls, System.Classes, System.Types, Vcl.Graphics, ES.BaseControls, ES.CfxClasses; type TEsCustomLayout = class(TEsBaseLayout) private FLocked: Boolean; procedure CMIsToolControl(var Message: TMessage); message CM_ISTOOLCONTROL; protected procedure CreateParams(var Params: TCreateParams); override; property UseDockManager default True; public constructor Create(AOwner: TComponent); override; property Color default clBtnFace; property DockManager; property Locked: Boolean read FLocked write FLocked default False; end; TEsLayout = class(TEsCustomLayout) published property Align; property Anchors; property AutoSize; property BiDiMode; property BorderWidth; property BufferedChildren;// TEsCustomControl property Color; property Constraints; property Ctl3D; property UseDockManager; property DockSite; property DoubleBuffered; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property IsCachedBuffer;// TEsCustomControl property IsCachedBackground;// TEsCustomControl property IsDrawHelper;// TEsCustomControl property IsOpaque;// TEsCustomControl property IsFullSizeBuffer;// TEsCustomControl property Locked; property Padding; property ParentBiDiMode; property ParentBackground; property ParentBufferedChildren;// TEsCustomControl property ParentColor; property ParentCtl3D; property ParentDoubleBuffered; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property TabStop; property Touch; property Visible; {$if CompilerVersion > 23} property StyleElements; {$ifend} property OnAlignInsertBefore; property OnAlignPosition; property OnCanResize; property OnClick; property OnConstrainedResize; property OnContextPopup; property OnDockDrop; property OnDockOver; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnGesture; property OnGetSiteInfo; property OnMouseActivate; property OnMouseDown; property OnMouseEnter; property OnMouseLeave; property OnMouseMove; property OnMouseUp; property OnResize; property OnPaint;// TEsCustomControl property OnPainting;// TEsCustomControl property OnStartDock; property OnStartDrag; property OnUnDock; end; TEsPanel = class(TEsLayout) private FFrameWidth: TFrameWidth; FFrameColor: TColor; FFrameStyle: TFrameStyle; procedure SetFrameColor(const Value: TColor); procedure SetFrameStyle(const Value: TFrameStyle); procedure SetFrameWidth(const Value: TFrameWidth); protected procedure Paint; override; procedure AdjustClientRect(var Rect: TRect); override; public constructor Create(AOwner: TComponent); override; published property BevelKind; property BevelInner; property BevelOuter; property FrameStyle: TFrameStyle read FFrameStyle write SetFrameStyle default TExFrameStyle.Raised; property FrameColor: TColor read FFrameColor write SetFrameColor default clBtnShadow; property FrameWidth: TFrameWidth read FFrameWidth write SetFrameWidth default 1; end; implementation uses ES.ExGraphics, ES.Utils, Vcl.Themes; procedure TEsCustomLayout.CMIsToolControl(var Message: TMessage); begin if not FLocked then Message.Result := 1; end; constructor TEsCustomLayout.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csSetCaption, csParentBackground, csDoubleClicks, csReplicatable, csPannable, csGestures]; Width := 185; Height := 41; UseDockManager := True; end; procedure TEsCustomLayout.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); // nope now end; { TEsPanel } procedure TEsPanel.AdjustClientRect(var Rect: TRect); begin inherited; if FrameStyle <> TExFrameStyle.None then begin Rect.Inflate(-GetFrameWidth(FrameStyle, FrameWidth), -GetFrameWidth(FrameStyle, FrameWidth)); end; end; constructor TEsPanel.Create(AOwner: TComponent); begin inherited; FFrameColor := clBtnShadow; FFrameWidth := 1; FFrameStyle := TExFrameStyle.Raised; end; procedure TEsPanel.Paint; begin if (csDesigning in ComponentState) and IsDrawHelper then DrawControlHelper(Self, [hoPadding, hoClientRect], GetFrameWidth(FrameStyle, FrameWidth)); if FrameStyle <> TExFrameStyle.None then if IsStyledBorderControl(Self) then DrawFrame(Canvas, ClientRect, FrameStyle, FrameWidth, StyleServices.GetSystemColor(FrameColor), StyleServices.GetSystemColor(clBtnHighlight), StyleServices.GetSystemColor(clBtnShadow)) else DrawFrame(Canvas, ClientRect, FrameStyle, FrameWidth, FrameColor, clBtnHighlight, clBtnShadow); end; procedure TEsPanel.SetFrameColor(const Value: TColor); begin if FFrameColor <> Value then begin FFrameColor := Value; Invalidate; end; end; procedure TEsPanel.SetFrameStyle(const Value: TFrameStyle); begin if FFrameStyle <> Value then begin FFrameStyle := Value; Realign; Invalidate; end; end; procedure TEsPanel.SetFrameWidth(const Value: TFrameWidth); begin if FFrameWidth <> Value then begin FFrameWidth := Value; Realign; Invalidate; end; end; end.
Исходный же код модуля содержащего TEsCustomControl и его версии-Layout-а TEsBaseLayout доступен по ссылке:
https://github.com/errorcalc/FreeEsVclComponents/blob/master/Source/ES.BaseControls.pas
И под спойлером
{******************************************************************************} { EsVclComponents/EsVclCore v3.0 } { errorsoft(c) 2009-2018 } { } { More beautiful things: errorsoft.org } { } { errorsoft@mail.ru | vk.com/errorsoft | github.com/errorcalc } { errorsoft@protonmail.ch | habrahabr.ru/user/error1024 } { } { Open this on github: github.com/errorcalc/FreeEsVclComponents } { } { You can order developing vcl/fmx components, please submit requests to mail. } { �� ������ �������� ���������� VCL/FMX ���������� �� �����. } {******************************************************************************} { This is the base unit, which must remain Delphi 7 support, and it should not be dependent on any other units! } unit ES.BaseControls; {$IF CompilerVersion >= 18} {$DEFINE VER180UP} {$IFEND} {$IF CompilerVersion >= 21} {$DEFINE VER210UP} {$IFEND} {$IF CompilerVersion >= 23} {$DEFINE VER230UP} {$IFEND} {$IF CompilerVersion >= 24} {$DEFINE VER240UP} {$IFEND} // see function CalcClientRect {$define FAST_CALC_CLIENTRECT} // see TEsBaseLayout.ContentRect {$define TEST_CONTROL_CONTENT_RECT} interface uses WinApi.Windows, System.Types, System.Classes, Vcl.Controls, Vcl.Graphics, {$IFDEF VER230UP}Vcl.Themes,{$ENDIF} WinApi.Messages, WinApi.Uxtheme, Vcl.Forms; const CM_ESBASE = CM_BASE + $0800; CM_PARENT_BUFFEREDCHILDRENS_CHANGED = CM_ESBASE + 1; EsVclCoreVersion = 3.0; type THelperOption = (hoPadding, hoBorder, hoClientRect); THelperOptions = set of THelperOption; TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect) of object; /// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary> TEsCustomControl = class(TWinControl) private // anti flicker and transparent magic FCanvas: TCanvas; CacheBitmap: HBITMAP;// Cache for buffer BitMap CacheBackground: HBITMAP;// Cache for background BitMap FIsCachedBuffer: Boolean; FIsCachedBackground: Boolean; FBufferedChildren: Boolean; FParentBufferedChildren: Boolean; FIsFullSizeBuffer: Boolean; // paint events FOnPaint: TPaintEvent; FOnPainting: TPaintEvent; // draw helper FIsDrawHelper: Boolean; // paint procedure SetIsCachedBuffer(Value: Boolean); procedure SetIsCachedBackground(Value: Boolean); procedure SetIsDrawHelper(const Value: Boolean); procedure SetIsOpaque(const Value: Boolean); function GetIsOpaque: Boolean; procedure SetBufferedChildren(const Value: Boolean); procedure SetParentBufferedChildren(const Value: Boolean); function GetTransparent: Boolean; procedure SetTransparent(const Value: Boolean); function IsBufferedChildrenStored: Boolean; // handle messages procedure WMPaint(var Message: TWMPaint); message WM_PAINT; procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED; procedure WMSize(var Message: TWMSize); message WM_SIZE; procedure CMParentBufferedChildrensChanged(var Message: TMessage); message CM_PARENT_BUFFEREDCHILDRENS_CHANGED; procedure DrawBackgroundForOpaqueControls(DC: HDC); // intercept mouse // procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; // other procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; procedure WMTextChanges(var Message: TMessage); message WM_SETTEXT; // fix procedure FixBufferedChildren(Reader: TReader); procedure FixParentBufferedChildren(Reader: TReader); procedure SetIsFullSizeBuffer(const Value: Boolean); protected // fix procedure DefineProperties(Filer: TFiler); override; // paint property Canvas: TCanvas read FCanvas; procedure DeleteCache;{$IFDEF VER210UP}inline;{$ENDIF} procedure Paint; virtual; procedure PaintWindow(DC: HDC); override; procedure PaintHandler(var Message: TWMPaint); procedure DrawBackground(DC: HDC); virtual; // other procedure UpdateText; dynamic; // property ParentBackground default True; property Transparent: Boolean read GetTransparent write SetTransparent default True;// analog of ParentBackground public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure UpdateBackground(Repaint: Boolean); overload; procedure UpdateBackground; overload; // ------------------ Properties for published ------------------------------------------------- property DoubleBuffered default False; {$IFDEF VER210UP} property ParentDoubleBuffered default False; {$ENDIF} // Painting for chidrens classes property OnPaint: TPaintEvent read FOnPaint write FOnPaint; property OnPainting: TPaintEvent read FOnPainting write FOnPainting; // BufferedChildrens property ParentBufferedChildren: Boolean read FParentBufferedChildren write SetParentBufferedChildren default True; property BufferedChildren: Boolean read FBufferedChildren write SetBufferedChildren stored IsBufferedChildrenStored; // External prop property IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False; property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False; property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False; property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False; property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write SetIsFullSizeBuffer default False; end; {$IFDEF VER180UP} TContentMargins = record type TMarginSize = 0..MaxInt; private Left: TMarginSize; Top: TMarginSize; Right: TMarginSize; Bottom: TMarginSize; public function Width: TMarginSize; function Height: TMarginSize; procedure Inflate(DX, DY: Integer); overload; procedure Inflate(DLeft, DTop, DRight, DBottom: Integer); overload; procedure Reset; constructor Create(Left, Top, Right, Bottom: TMarginSize); overload; end; /// <summary> ONLY INTERNAL USE! THIS CLASS CAN BE DELETED! (USE TEsCustomControl OR TEsCustomLayot) </summary> TEsBaseLayout = class(TEsCustomControl) private FBorderWidth: TBorderWidth; procedure SetBorderWidth(const Value: TBorderWidth); protected procedure AlignControls(AControl: TControl; var Rect: TRect); override; procedure AdjustClientRect(var Rect: TRect); override; procedure Paint; override; // new procedure CalcContentMargins(var Margins: TContentMargins); virtual; public constructor Create(AOwner: TComponent); override; function ContentRect: TRect; virtual; function ContentMargins: TContentMargins; inline; property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0; property BufferedChildren default True; end; /// <summary> The GraphicControl, supports Padding and IsDrawHelper property </summary> TEsGraphicControl = class(TGraphicControl) private FPadding: TPadding; FIsDrawHelper: Boolean; function GetPadding: TPadding; procedure SetPadding(const Value: TPadding); procedure PaddingChange(Sender: TObject); procedure SetIsDrawHelper(const Value: Boolean); protected procedure Paint; override; function HasPadding: Boolean; // new procedure CalcContentMargins(var Margins: TContentMargins); virtual; public destructor Destroy; override; property Padding: TPadding read GetPadding write SetPadding; function ContentRect: TRect; virtual; function ContentMargins: TContentMargins; inline; property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False; end; procedure DrawControlHelper(Control: TControl; Options: THelperOptions; FrameWidth: Integer = 0); overload; procedure DrawControlHelper(Canvas: TCanvas; Rect: TRect; BorderWidth: TBorderWidth; Padding: TPadding; Options: THelperOptions); overload; {$ENDIF} function CalcClientRect(Control: TControl): TRect; procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False); implementation uses System.SysUtils, System.TypInfo; type TOpenCtrl = class(TWinControl) public property BorderWidth; end; // Old delphi support {$IFNDEF VER210UP} function RectWidth(const Rect: TRect): Integer; begin Result := Rect.Right - Rect.Left; end; function RectHeight(const Rect: TRect): Integer; begin Result := Rect.Bottom - Rect.Top; end; {$ENDIF} {$IFDEF VER210UP} {$REGION 'DrawControlHelper'} procedure DrawControlHelper(Canvas: TCanvas; Rect: TRect; BorderWidth: TBorderWidth; Padding: TPadding; Options: THelperOptions); procedure Line(Canvas: TCanvas; x1, y1, x2, y2: Integer); begin Canvas.MoveTo(x1, y1); Canvas.LineTo(x2, y2); end; var SaveBk: TColor; SavePen, SaveBrush: TPersistent; begin SavePen := nil; SaveBrush := nil; try if Canvas.Handle = 0 then Exit; // save canvas state SavePen := TPen.Create; SavePen.Assign(Canvas.Pen); SaveBrush := TBrush.Create; SaveBrush.Assign(Canvas.Brush); Canvas.Pen.Mode := pmNot; Canvas.Pen.Style := psDash; Canvas.Brush.Style := bsClear; // ClientRect Helper if THelperOption.hoClientRect in Options then begin SaveBk := SetBkColor(Canvas.Handle, RGB(127,255,255)); DrawFocusRect(Canvas.Handle, Rect); SetBkColor(Canvas.Handle, SaveBk); end; // Border Helper if THelperOption.hoBorder in Options then begin if (BorderWidth <> 0) and (BorderWidth * 2 <= RectWidth(Rect)) and (BorderWidth * 2 <= RectHeight(Rect)) then Canvas.Rectangle(Rect.Left + BorderWidth, Rect.Top + BorderWidth, Rect.Right - BorderWidth, Rect.Bottom - BorderWidth); end; // Padding Helper if THelperOption.hoPadding in Options then begin if (BorderWidth + Padding.Top < RectHeight(Rect) - BorderWidth - Padding.Bottom) and (BorderWidth + Padding.Left < RectWidth(Rect) - BorderWidth - Padding.Right) then begin Canvas.Pen.Style := psDot; if Padding.Left <> 0 then Line(Canvas, Rect.Left + Padding.Left + BorderWidth, Rect.Top + Padding.Top + BorderWidth, Rect.Left + Padding.Left + BorderWidth, Rect.Bottom - Padding.Bottom - BorderWidth - 1); if Padding.Top <> 0 then Line(Canvas, Rect.Left + Padding.Left + BorderWidth, Rect.Top + Padding.Top + BorderWidth, Rect.Right - Padding.Right - BorderWidth - 1, Rect.Top + Padding.Top + BorderWidth); if Padding.Right <> 0 then Line(Canvas, Rect.Right - Padding.Right - BorderWidth - 1, Rect.Top + Padding.Top + BorderWidth, Rect.Right - Padding.Right - BorderWidth - 1, Rect.Bottom - Padding.Bottom - BorderWidth - 1); if Padding.Bottom <> 0 then Line(Canvas, Rect.Left + Padding.Left + BorderWidth, Rect.Bottom - Padding.Bottom - BorderWidth - 1, Rect.Right - Padding.Right - BorderWidth - 1, Rect.Bottom - Padding.Bottom - BorderWidth - 1); end; end; Canvas.Pen.Assign(SavePen); Canvas.Brush.Assign(SaveBrush); finally SavePen.Free; SaveBrush.Free; end; end; procedure DrawControlHelper(Control: TControl; Options: THelperOptions; FrameWidth: Integer = 0); var Canvas: TCanvas; Padding: TPadding; BorderWidth: Integer; MyCanvas: Boolean; R: TRect; begin MyCanvas := False; Canvas := nil; Padding := nil; BorderWidth := 0; // if win control if Control is TWinControl then begin TOpenCtrl(Control).AdjustClientRect(R); // get padding Padding := TWinControl(Control).Padding; // get canvas if Control is TEsCustomControl then Canvas := TEsCustomControl(Control).Canvas else begin MyCanvas := True; Canvas := TControlCanvas.Create; TControlCanvas(Canvas).Control := Control; end; // get border width if Control is TEsBaseLayout then BorderWidth := TEsBaseLayout(Control).BorderWidth else BorderWidth := TOpenCtrl(Control).BorderWidth; end else if Control is TGraphicControl then begin // get canvas Canvas := TEsGraphicControl(Control).Canvas; if Control is TEsGraphicControl then Padding := TEsGraphicControl(Control).Padding; end; try R := Control.ClientRect; R.Inflate(-FrameWidth, -FrameWidth); DrawControlHelper(Canvas, R, BorderWidth, Padding, Options); finally if MyCanvas then Canvas.Free; end; end; {$ENDREGION} {$ENDIF} function IsStyledClientControl(Control: TControl): Boolean; begin Result := False; {$IFDEF VER230UP} if Control = nil then Exit; if StyleServices.Enabled then begin Result := {$ifdef VER240UP}(seClient in Control.StyleElements) and{$endif} TStyleManager.IsCustomStyleActive; end; {$ENDIF} end; function CalcClientRect(Control: TControl): TRect; var {$ifdef FAST_CALC_CLIENTRECT} Info: TWindowInfo; {$endif} IsFast: Boolean; begin {$ifdef FAST_CALC_CLIENTRECT} IsFast := True; {$else} IsFast := False; {$endif} Result := Rect(0, 0, Control.Width, Control.Height); // Only TWinControl's has non client area if not (Control is TWinControl) then Exit; // Fast method not work for controls not having Handle if not TWinControl(Control).Handle <> 0 then IsFast := False; if IsFast then begin ZeroMemory(@Info, SizeOf(TWindowInfo)); Info.cbSize := SizeOf(TWindowInfo); GetWindowInfo(TWinControl(Control).Handle, info); Result.Left := Info.rcClient.Left - Info.rcWindow.Left; Result.Top := Info.rcClient.Top - Info.rcWindow.Top; Result.Right := -Info.rcWindow.Left + Info.rcClient.Right; Result.Top := -Info.rcWindow.Top + Info.rcClient.Bottom; end else begin Control.Perform(WM_NCCALCSIZE, 0, LParam(@Result)); end; end; procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False); var ClientRect: TRect; P: TPoint; SaveIndex: Integer; begin if Control.Parent = nil then Exit; SaveIndex := SaveDC(DC); GetViewportOrgEx(DC, P); // if control has non client border then need additional offset viewport ClientRect := Control.ClientRect; if (ClientRect.Right <> Control.Width) or (ClientRect.Bottom <> Control.Height) then begin ClientRect := CalcClientRect(Control); SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil); end else SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil); IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight); Control.Parent.Perform(WM_ERASEBKGND, DC, 0); Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT); RestoreDC(DC, SaveIndex); if InvalidateParent then if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and not (csDesigning in Control.ComponentState)and not (Control.Parent is TEsCustomControl) then begin Control.Parent.Invalidate; end; SetViewportOrgEx(DC, P.X, P.Y, nil); end; procedure BitmapDeleteAndNil(var Bitmap: HBITMAP);{$IFDEF VER210UP}inline;{$ENDIF} begin if Bitmap <> 0 then begin DeleteObject(Bitmap); Bitmap := 0; end; end; procedure TEsCustomControl.CMParentBufferedChildrensChanged(var Message: TMessage); begin if FParentBufferedChildren then begin if Parent <> nil then begin if Parent is TEsCustomControl then BufferedChildren := TEsCustomControl(Parent).BufferedChildren else BufferedChildren := False; end; FParentBufferedChildren := True; end; end; procedure TEsCustomControl.CMTextChanged(var Message: TMessage); begin inherited; UpdateText; end; procedure TEsCustomControl.WMTextChanges(var Message: TMessage); begin Inherited; UpdateText; end; constructor TEsCustomControl.Create(AOwner: TComponent); begin inherited Create(AOwner); // init ControlStyle := ControlStyle - [csOpaque] + [csParentBackground]; {$IFDEF VER210UP} ParentDoubleBuffered := False; {$ENDIF} CacheBitmap := 0; CacheBackground := 0; // canvas FCanvas := TControlCanvas.Create; TControlCanvas(FCanvas).Control := Self; // new props FParentBufferedChildren := True; FBufferedChildren := False; FIsCachedBuffer := False; FIsCachedBackground := False; FIsFullSizeBuffer := False; FIsDrawHelper := False; end; // temp fix procedure TEsCustomControl.DefineProperties(Filer: TFiler); begin inherited; Filer.DefineProperty('BufferedChildrens', FixBufferedChildren, nil, False); Filer.DefineProperty('ParentBufferedChildrens', FixParentBufferedChildren, nil, False); end; // ok procedure TEsCustomControl.DeleteCache; begin BitmapDeleteAndNil(CacheBitmap); BitmapDeleteAndNil(CacheBackground); end; destructor TEsCustomControl.Destroy; begin FCanvas.Free; DeleteCache; inherited; end; procedure TEsCustomControl.DrawBackground(DC: HDC); begin DrawParentImage(Self, DC, False); end; // hack for bad graphic controls procedure TEsCustomControl.DrawBackgroundForOpaqueControls(DC: HDC); var i: integer; Control: TControl; Prop: Pointer; begin for i := 0 to ControlCount - 1 do begin Control := Controls[i]; if (Control is TGraphicControl) and (csOpaque in Control.ControlStyle) and Control.Visible and (not (csDesigning in ComponentState) or not (csNoDesignVisible in ControlStyle) {$IFDEF VER210UP}or not (csDesignerHide in Control.ControlState){$ENDIF}) then begin // Necessary to draw a background if the control has a Property 'Transparent' and hasn't a Property 'Color' Prop := GetPropInfo(Control.ClassInfo, 'Transparent'); if Prop <> nil then begin Prop := GetPropInfo(Control.ClassInfo, 'Color'); if Prop = nil then FillRect(DC, Rect(Control.Left, Control.Top, Control.Left + Control.Width, Control.Top + Control.Height), Brush.Handle); end; end; end; end; (*procedure TEsCustomControl.EndCachedBackground; begin FIsCachedBackground := StoredCachedBackground; end; procedure TEsCustomControl.EndCachedBuffer; begin FIsCachedBuffer := StoredCachedBuffer; end;*) // temp fix procedure TEsCustomControl.FixBufferedChildren(Reader: TReader); begin BufferedChildren := Reader.ReadBoolean; end; // temp fix procedure TEsCustomControl.FixParentBufferedChildren(Reader: TReader); begin ParentBufferedChildren := Reader.ReadBoolean; end; function TEsCustomControl.GetIsOpaque: Boolean; begin Result := csOpaque in ControlStyle; end; function TEsCustomControl.GetTransparent: Boolean; begin Result := ParentBackground; end; procedure TEsCustomControl.Paint; var SaveBk: TColor; begin // for Design time if IsDrawHelper and(csDesigning in ComponentState) then begin SaveBk := SetBkColor(Canvas.Handle, RGB(127,255,255)); DrawFocusRect(Canvas.Handle, Self.ClientRect); SetBkColor(Canvas.Handle, SaveBk); end; end; { TODO -cCRITICAL : 22.02.2013: eliminate duplication of code! } procedure TEsCustomControl.PaintHandler(var Message: TWMPaint); var PS: TPaintStruct; BufferDC: HDC; BufferBitMap: HBITMAP; UpdateRect: TRect; SaveViewport: TPoint; Region: HRGN; DC: HDC; IsBeginPaint: Boolean; begin BufferBitMap := 0; BufferDC := 0; DC := 0; Region := 0; IsBeginPaint := Message.DC = 0; try if IsBeginPaint then begin DC := BeginPaint(Handle, PS); {$IFDEF VER230UP} if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then UpdateRect := ClientRect // I had to use a crutch to ClientRect, due to the fact that // VCL.Styles.TCustomStyle.DoDrawParentBackground NOT use relative coordinates, // ie ignores SetViewportOrgEx! // This function uses ClientToScreen and ScreenToClient for coordinates calculation! else {$endif} UpdateRect := PS.rcPaint; end else begin DC := Message.DC; {$IFDEF VER230UP} if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then UpdateRect := ClientRect else {$endif} if GetClipBox(DC, UpdateRect) = ERROR then UpdateRect := ClientRect; end; //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintWindow, Please sync this code!!! //------------------------------------------------------------------------------------------------ // if control not double buffered then create or assign buffer if not DoubleBuffered then begin BufferDC := CreateCompatibleDC(DC); // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer): // return <> 0 => need to double buffer || return = 0 => no need to double buffer if BufferDC <> 0 then begin // Using the cache if possible if FIsCachedBuffer or FIsFullSizeBuffer then begin // Create cache if need if CacheBitmap = 0 then begin BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight); // Assign to cache if need if FIsCachedBuffer then CacheBitmap := BufferBitMap; end else BufferBitMap := CacheBitmap; // Assign region for minimal overdraw Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height); SelectClipRgn(BufferDC, Region); end else // Create buffer BufferBitMap := CreateCompatibleBitmap(DC, UpdateRect.Right - UpdateRect.Left, UpdateRect.Bottom - UpdateRect.Top); // Select buffer bitmap SelectObject(BufferDC, BufferBitMap); // [change coord], if need // Moving update region to the (0,0) point if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin GetViewportOrgEx(BufferDC, SaveViewport); SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil); end; end else BufferDC := DC; end else BufferDC := DC; //------------------------------------------------------------------------------------------------ // DEFAULT HANDLER: Message.DC := BufferDC; inherited PaintHandler(Message); finally try //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintWindow, Please sync this code!!! //------------------------------------------------------------------------------------------------ try // draw to window if not DoubleBuffered then begin if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin // [restore coord], if need SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil); BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY); end else begin BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY); end; end; finally if BufferDC <> DC then DeleteObject(BufferDC); if Region <> 0 then DeleteObject(Region); // delete buffer, if need if not FIsCachedBuffer and (BufferBitMap <> 0) then DeleteObject(BufferBitMap); end; //------------------------------------------------------------------------------------------------ finally // end paint, if need if IsBeginPaint then EndPaint(Handle, PS); end; end; end; { TODO -cMAJOR : 22.02.2013: See: PaintHandler, need eliminate duplication of code! } procedure TEsCustomControl.PaintWindow(DC: HDC); var TempDC: HDC; UpdateRect: TRect; //--- BufferDC: HDC; BufferBitMap: HBITMAP; Region: HRGN; SaveViewport: TPoint; BufferedThis: Boolean; begin BufferBitMap := 0; Region := 0; BufferDC := 0; if GetClipBox(DC, UpdateRect) = ERROR then UpdateRect := ClientRect; BufferedThis := not BufferedChildren; // fix for designer selection BufferedThis := BufferedThis or (csDesigning in ComponentState); try if BufferedThis then begin //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintHandler, Please sync this code!!! //------------------------------------------------------------------------------------------------ // if control not double buffered then create or assign buffer if not DoubleBuffered then begin BufferDC := CreateCompatibleDC(DC); // CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer): // return <> 0 => need to double buffer || return = 0 => no need to double buffer if BufferDC <> 0 then begin // Using the cache if possible if FIsCachedBuffer or FIsFullSizeBuffer then begin // Create cache if need if CacheBitmap = 0 then begin BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight); // Assign to cache if need if FIsCachedBuffer then CacheBitmap := BufferBitMap; end else BufferBitMap := CacheBitmap; // Assign region for minimal overdraw Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height); SelectClipRgn(BufferDC, Region); end else // Create buffer BufferBitMap := CreateCompatibleBitmap(DC, RectWidth(UpdateRect), RectHeight(UpdateRect)); // Select buffer bitmap SelectObject(BufferDC, BufferBitMap); // [change coord], if need // Moving update region to the (0,0) point if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin GetViewportOrgEx(BufferDC, SaveViewport); SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil); end; end else BufferDC := DC; end else BufferDC := DC; //------------------------------------------------------------------------------------------------ end else BufferDC := DC; if not(csOpaque in ControlStyle) then if ParentBackground then begin if FIsCachedBackground then begin if CacheBackground = 0 then begin TempDC := CreateCompatibleDC(DC); CacheBackground := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight); SelectObject(TempDC, CacheBackground); DrawBackground(TempDC); //DrawParentImage(Self, TempDC, False); DeleteDC(TempDC); end; TempDC := CreateCompatibleDC(BufferDC); SelectObject(TempDC, CacheBackground); if not FIsCachedBuffer then BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY) else BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY); DeleteDC(TempDC); end else DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False); end else if (not DoubleBuffered or (DC <> 0)) then if not IsStyledClientControl(Self) then FillRect(BufferDC, ClientRect, Brush.Handle) else begin SetDCBrushColor(BufferDC, ColorToRGB({$ifdef VER230UP}StyleServices.GetSystemColor(Color){$else}Color{$endif})); FillRect(BufferDC, ClientRect, GetStockObject(DC_BRUSH)); end; FCanvas.Lock; try Canvas.Handle := BufferDC; TControlCanvas(Canvas).UpdateTextFlags; if Assigned(FOnPainting) then FOnPainting(Self, Canvas, ClientRect); Paint; if Assigned(FOnPaint) then FOnPaint(Self, Canvas, ClientRect); finally FCanvas.Handle := 0; FCanvas.Unlock; end; finally if BufferedThis then begin //------------------------------------------------------------------------------------------------ // Duplicate code, see PaintHandler, Please sync this code!!! //------------------------------------------------------------------------------------------------ try // draw to window if not DoubleBuffered then begin if not(FIsCachedBuffer or FIsFullSizeBuffer) then begin // [restore coord], if need SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil); BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY); end else begin BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY); end; end; finally if BufferDC <> DC then DeleteObject(BufferDC); if Region <> 0 then DeleteObject(Region); // delete buffer, if need if not FIsCachedBuffer and (BufferBitMap <> 0) then DeleteObject(BufferBitMap); end; //------------------------------------------------------------------------------------------------ end; end; end; // ok function TEsCustomControl.IsBufferedChildrenStored: Boolean; begin Result := not ParentBufferedChildren; end; // ok procedure TEsCustomControl.SetBufferedChildren(const Value: Boolean); begin if Value <> FBufferedChildren then begin FBufferedChildren := Value; FParentBufferedChildren := False; NotifyControls(CM_PARENT_BUFFEREDCHILDRENS_CHANGED); end; end; procedure TEsCustomControl.SetIsCachedBackground(Value: Boolean); begin if Value <> FIsCachedBackground then begin FIsCachedBackground := Value; if not FIsCachedBackground then BitmapDeleteAndNil(CacheBackground); end; end; procedure TEsCustomControl.SetIsCachedBuffer(Value: Boolean); begin if Value <> FIsCachedBuffer then begin FIsCachedBuffer := Value; if not FIsCachedBuffer then BitmapDeleteAndNil(CacheBitmap); end; end; procedure TEsCustomControl.SetIsDrawHelper(const Value: Boolean); begin if Value <> FIsDrawHelper then begin FIsDrawHelper := Value; if csDesigning in ComponentState then Invalidate; end; end; procedure TEsCustomControl.SetIsFullSizeBuffer(const Value: Boolean); begin DeleteCache; end; // ok procedure TEsCustomControl.SetIsOpaque(const Value: Boolean); begin if Value <> (csOpaque in ControlStyle) then begin if Value then ControlStyle := ControlStyle + [csOpaque] else ControlStyle := ControlStyle - [csOpaque]; Invalidate; end; end; // ok procedure TEsCustomControl.SetParentBufferedChildren(const Value: Boolean); begin if Value <> FParentBufferedChildren then begin FParentBufferedChildren := Value; if (Parent <> nil) and not (csReading in ComponentState) then Perform(CM_PARENT_BUFFEREDCHILDRENS_CHANGED, 0, 0); end; end; procedure TEsCustomControl.SetTransparent(const Value: Boolean); begin ParentBackground := Value; end; procedure TEsCustomControl.UpdateBackground; begin UpdateBackground(True); end; procedure TEsCustomControl.UpdateText; begin end; procedure TEsCustomControl.UpdateBackground(Repaint: Boolean); begin // Delete cache background BitmapDeleteAndNil(CacheBackground); if Repaint then Invalidate; end; procedure TEsCustomControl.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin if DoubleBuffered then begin inherited; // Message.Result := 1; end else begin if ControlCount <> 0 then DrawBackgroundForOpaqueControls(Message.DC); Message.Result := 1; end; end; //procedure TEsCustomControl.WMNCHitTest(var Message: TWMNCHitTest); //begin // if (FIsTransparentMouse) and not(csDesigning in ComponentState) then // Message.Result := HTTRANSPARENT // else // inherited; //end; procedure TEsCustomControl.WMPaint(var Message: TWMPaint); begin ControlState := ControlState + [csCustomPaint]; // buffered childen aviable only for not DoubleBuffered controls if BufferedChildren and (not FDoubleBuffered) and not (csDesigning in ComponentState) then // fix for designer selection begin PaintHandler(Message)// My new PaintHandler end else inherited; ControlState := ControlState - [csCustomPaint]; end; procedure TEsCustomControl.WMSize(var Message: TWMSize); begin DeleteCache; inherited; end; procedure TEsCustomControl.WMWindowPosChanged(var Message: TWMWindowPosChanged); begin if not (csOpaque in ControlStyle) and ParentBackground{ and not CachedBackground }then Invalidate; Inherited; end; {$IFDEF VER180UP} { TEsBaseLayout } constructor TEsBaseLayout.Create(AOwner: TComponent); begin inherited; FBufferedChildren := True; end; procedure TEsBaseLayout.AdjustClientRect(var Rect: TRect); begin inherited AdjustClientRect(Rect); if BorderWidth <> 0 then begin InflateRect(Rect, -Integer(BorderWidth), -Integer(BorderWidth)); end; end; procedure TEsBaseLayout.AlignControls(AControl: TControl; var Rect: TRect); begin inherited AlignControls(AControl, Rect); if (csDesigning in ComponentState) and IsDrawHelper then Invalidate; end; procedure TEsBaseLayout.CalcContentMargins(var Margins: TContentMargins); begin Margins.Create(Padding.Left, Padding.Top, Padding.Right, Padding.Bottom); if BorderWidth <> 0 then Margins.Inflate(Integer(BorderWidth), Integer(BorderWidth)); end; function TEsBaseLayout.ContentMargins: TContentMargins; begin Result.Reset; CalcContentMargins(Result); end; function TEsBaseLayout.ContentRect: TRect; var ContentMargins: TContentMargins; begin Result := ClientRect; ContentMargins.Reset; CalcContentMargins(ContentMargins); Inc(Result.Left, ContentMargins.Left); Inc(Result.Top, ContentMargins.Top); Dec(Result.Right, ContentMargins.Right); Dec(Result.Bottom, ContentMargins.Bottom); {$ifdef TEST_CONTROL_CONTENT_RECT} if Result.Left > Result.Right then Result.Right := Result.Left; if Result.Top > Result.Bottom then Result.Bottom := Result.Top; {$endif} end; procedure TEsBaseLayout.Paint; begin if (csDesigning in ComponentState) and IsDrawHelper then DrawControlHelper(Self, [hoBorder, hoPadding, hoClientRect]); end; procedure TEsBaseLayout.SetBorderWidth(const Value: TBorderWidth); begin if Value <> FBorderWidth then begin FBorderWidth := Value; Realign; Invalidate; end; end; { TEsGraphicControl } procedure TEsGraphicControl.CalcContentMargins(var Margins: TContentMargins); begin if FPadding <> nil then Margins.Create(Padding.Left, Padding.Top, Padding.Right, Padding.Bottom) else Margins.Reset; end; function TEsGraphicControl.ContentMargins: TContentMargins; begin Result.Reset; CalcContentMargins(Result); end; function TEsGraphicControl.ContentRect: TRect; var ContentMargins: TContentMargins; begin Result := ClientRect; ContentMargins.Reset; CalcContentMargins(ContentMargins); Inc(Result.Left, ContentMargins.Left); Inc(Result.Top, ContentMargins.Top); Dec(Result.Right, ContentMargins.Right); Dec(Result.Bottom, ContentMargins.Bottom); {$ifdef TEST_CONTROL_CONTENT_RECT} if Result.Left > Result.Right then Result.Right := Result.Left; if Result.Top > Result.Bottom then Result.Bottom := Result.Top; {$endif} end; destructor TEsGraphicControl.Destroy; begin FPadding.Free; inherited; end; function TEsGraphicControl.GetPadding: TPadding; begin if FPadding = nil then begin FPadding := TPadding.Create(nil); FPadding.OnChange := PaddingChange; end; Result := FPadding; end; function TEsGraphicControl.HasPadding: Boolean; begin Result := FPadding <> nil; end; procedure TEsGraphicControl.PaddingChange(Sender: TObject); begin AdjustSize; Invalidate; if (FPadding.Left = 0) and (FPadding.Top = 0) and (FPadding.Right = 0) and (FPadding.Bottom = 0) then FreeAndNil(FPadding); end; procedure TEsGraphicControl.Paint; begin if (csDesigning in ComponentState) and IsDrawHelper then DrawControlHelper(Self, [hoPadding, hoClientRect]); end; procedure TEsGraphicControl.SetIsDrawHelper(const Value: Boolean); begin if FIsDrawHelper <> Value then begin FIsDrawHelper := Value; if csDesigning in ComponentState then Invalidate; end; end; procedure TEsGraphicControl.SetPadding(const Value: TPadding); begin Padding.Assign(Value); end; { TContentMargins } constructor TContentMargins.Create(Left, Top, Right, Bottom: TMarginSize); begin Self.Left := Left; Self.Top := Top; Self.Right := Right; Self.Bottom := Bottom; end; procedure TContentMargins.Reset; begin Left := 0; Top := 0; Right := 0; Bottom := 0; end; function TContentMargins.Height: TMarginSize; begin Result := Top + Bottom; end; procedure TContentMargins.Inflate(DX, DY: Integer); begin Inc(Left, DX); Inc(Right, DX); Inc(Top, DY); Inc(Bottom, DY); end; procedure TContentMargins.Inflate(DLeft, DTop, DRight, DBottom: Integer); begin Inc(Left, DLeft); Inc(Right, DRight); Inc(Top, DTop); Inc(Bottom, DBottom); end; function TContentMargins.Width: TMarginSize; begin Result := Left + Right; end; {$ENDIF} end.
Но лучше использовать бесплатную библиотеку VCL компонентов EsVclComponents, которая содержит в себе данные модули и еще много полезных компонентов и классов:
https://github.com/errorcalc/FreeEsVclComponents (библиотека также доступна в пакетном менеджере GetIt для Delphi Berlin, правда не самая свежая версия).
Посмотрите примеры, особенно "\Samples\BufferedChildrens", где видно "магию" подавления мерцания.
Возможно стоит написать отдельную обзорную статью о данной библиотеке?
Спасибо что дочитали статью до конца! Надеюсь, я помог вам побороть проблему мерцания в ваших приложениях и компонентах.
Вы можете помочь проекту, написав мне, где вы используете данные компоненты и приложив скриншот с примером использования.
