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