Delphi и C++Builder разработчики, использующие VCL не по наслышке знают о вездесущей проблеме мерцания контролов.
Мерцание происходит при перерисовке, вследствие того, что сначала отрисовываеться фон компонента, и только потом сам компонент.
И если в случае с наследниками от TWinControl частичным решением проблемы является установка свойства DoubleBuffered в True, что заставляет контрол отрисовываться в буфере(однако DoubleBuffered работает тоже не идеально, к прим.: контрол перестает быть прозрачным), то в случае с TGraphicControl решение с DoubleBuffered просто невозможно, из-за отсутствия у TGraphicControl окна, установка же DoubleBuffered в True у родителя не помогает, из-за того что отрисовка вложенных TGraphicControl-ов происходит уже после прорисовки родителя в буфере.
Обычно остается только одно — смириться с мерцанием, и максимально упростить отрисовку для минимизации эффекта, или использовать по возможности исключительно TWinControl-ы, что не всегда возможно и удобно.
Однажды намучившись с мерцанием, я не выдержал и решил решить эту проблему, раз и навсегда!
Как мне удалось решить проблему?
Заранее извиняюсь за некоторую сумбурность подачи, и недосказанность, описывать подобные вещи довольно сложно, однако поделиться с сообществом хочется.
Был разработан класс TEsCustomControl = class(TWinControl), который осуществляет альтернативную буферизацию(при DoubleBuffered = False, иначе используется родная буферизация VCL).
Класс имеет свойство BufferedChildrens, при активации которого отрисовка вложенных TGraphicControl-ов происходит в буфере, что полностью избавляет от мерцания.
К счастью в VCL нужные методы отрисовки объявлены не как private, что и позволило реализовать полную буферизацию.
Для того чтобы компонент выглядел прозрачным, необходимо отрисовать на нем фон нижележащего компонента, что осуществляется с помощью процедуры DrawParentImage.
procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);
var
ClientRect: TRect;
P: TPoint;
SaveIndex: Integer;
begin
if Control.Parent = nil then
Exit;
SaveIndex := SaveDC(DC);
GetViewportOrgEx(DC, P);
// if control has non client border then need additional offset viewport
ClientRect := Control.ClientRect;
if (ClientRect.Right <> Control.Width) or (ClientRect.Bottom <> Control.Height) then
begin
ClientRect := CalcClientRect(Control);
SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil);
end else
SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil);
IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
// Control.Parent.Perform(WM_PAINT, DC, 0);
Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT);
RestoreDC(DC, SaveIndex);
if InvalidateParent then
if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and
not (csDesigning in Control.ComponentState)and not (Control.Parent is TEsCustomControl) then
begin
Control.Parent.Invalidate;
end;
SetViewportOrgEx(DC, P.X, P.Y, nil);
end;Буферизация происходит за счет того что компонент в переопределенном методе PaintWindow отрисовываеться не непосредственно на предоставленный хендл, а на временный(или нет в зависимости от свойства IsCachedBuffer) HBITMAP, и уже после полной отрисовки копируется функцией BitBlt.
(Довольно много кода, из-за многих частных случаев)
TEsCustomControl.PaintWindow
procedure TEsCustomControl.PaintWindow(DC: HDC);
var
TempDC: HDC;
UpdateRect: TRect;
//---
BufferDC: HDC;
BufferBitMap: HBITMAP;
Region: HRGN;
SaveViewport: TPoint;
BufferedThis: Boolean;
begin
BufferBitMap := 0;
Region := 0;
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-ов.
TEsCustomControl.PaintHandler
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
Посмотрите примеры, особенно "SamplesBufferedChildrens", где видно "магию" подавления мерцания.
Возможно стоит написать отдельную обзорную статью о данной библиотеке?
Спасибо что дочитали статью до конца!
Надеюсь я помог вам побороть проблему мерцания в ваших приложениях и компонентах.
Автор: Error1024
