Delphi и C++Builder разработчики, использующие VCL не по наслышке знают о вездесущей проблеме мерцания контролов. Мерцание происходит при перерисовке, вследствие того, что сначала отрисовываеться фон компонента, и только потом сам компонент.
И если в случае с наследниками от TWinControl частичным решением проблемы является установка свойства DoubleBuffered в True, что заставляет контрол отрисовываться в буфере (однако DoubleBuffered работает тоже не идеально, к прим.: контрол перестает быть прозрачным), то в случае с TGraphicControl решение с DoubleBuffered просто невозможно, из-за отсутствия у TGraphicControl окна, установка же DoubleBuffered в True у родителя не помогает, из-за того что отрисовка вложенных TGraphicControl-ов происходит уже после прорисовки родителя в буфере.
Обычно остается только одно — смириться с мерцанием, и максимально упростить отрисовку для минимизации эффекта, или использовать по возможности исключительно TWinControl-ы, что не всегда возможно и удобно.
Однажды намучившись с мерцанием, я не выдержал и решил решить эту проблему, раз и навсегда!
Как мне удалось решить проблему?
Заранее извиняюсь за некоторую сумбурность подачи, и недосказанность, описывать подобные вещи довольно сложно, однако поделиться с сообществом хочется.
Был разработан класс TEsCustomControl = class(TWinControl), который осуществляет альтернативную буферизацию (при DoubleBuffered = False, иначе используется родная буферизация VCL).
Класс имеет свойство BufferedChildrens, при активации которого отрисовка вложенных TGraphicControl-ов происходит в буфере, что полностью избавляет от мерцания.
К счастью в VCL нужные методы отрисовки объявлены не как private, что и позволило реализовать полную буферизацию.
Для того чтобы компонент выглядел прозрачным, необходимо отрисовать на нем фон нижележащего компонента, что осуществляется с помощью процедуры DrawParentImage.
procedure DrawParentImage(Control: TControl; DC: HDC; InvalidateParent: Boolean = False);
var
ClientRect: TRect;
P: TPoint;
SaveIndex: Integer;
begin
if Control.Parent = nil then
Exit;
SaveIndex := SaveDC(DC);
GetViewportOrgEx(DC, P);
// if control has non client border then need additional offset viewport
ClientRect := Control.ClientRect;
if (ClientRect.Right <> Control.Width) or (ClientRect.Bottom <> Control.Height) then
begin
ClientRect := CalcClientRect(Control);
SetViewportOrgEx(DC, P.X - Control.Left - ClientRect.Left, P.Y - Control.Top - ClientRect.Top, nil);
end else
SetViewportOrgEx(DC, P.X - Control.Left, P.Y - Control.Top, nil);
IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, Control.Parent.ClientHeight);
Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
// Control.Parent.Perform(WM_PAINT, DC, 0);
Control.Parent.Perform(WM_PRINTCLIENT, DC, PRF_CLIENT);
RestoreDC(DC, SaveIndex);
if InvalidateParent then
if not (Control.Parent is TCustomControl) and not (Control.Parent is TCustomForm) and
not (csDesigning in Control.ComponentState)and not (Control.Parent is TEsCustomControl) then
begin
Control.Parent.Invalidate;
end;
SetViewportOrgEx(DC, P.X, P.Y, nil);
end;Буферизация происходит за счет того что компонент в переопределенном методе PaintWindow отрисовываеться не непосредственно на предоставленный хендл, а на временный (или нет в зависимости от свойства IsCachedBuffer) HBITMAP, и уже после полной отрисовки копируется функцией BitBlt.
(Довольно много кода, из-за многих частных случаев)
TEsCustomControl.PaintWindow
procedure TEsCustomControl.PaintWindow(DC: HDC);
var
TempDC: HDC;
UpdateRect: TRect;
//---
BufferDC: HDC;
BufferBitMap: HBITMAP;
Region: HRGN;
SaveViewport: TPoint;
BufferedThis: Boolean;
begin
BufferBitMap := 0;
Region := 0;
BufferDC := 0;
if GetClipBox(DC, UpdateRect) = ERROR then
UpdateRect := ClientRect;
BufferedThis := not BufferedChildrens;
try
if BufferedThis then
begin
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintHandler, Please sync this code!!!
//------------------------------------------------------------------------------------------------
// if control not double buffered then create or assign buffer
if not DoubleBuffered then
begin
BufferDC := CreateCompatibleDC(DC);
// CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
// return <> 0 => need to double buffer || return = 0 => no need to double buffer
if BufferDC <> 0 then
begin
// Using the cache if possible
if FIsCachedBuffer or FIsFullSizeBuffer then
begin
// Create cache if need
if CacheBitmap = 0 then
begin
BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
// Assign to cache if need
if FIsCachedBuffer then
CacheBitmap := BufferBitMap;
end
else
BufferBitMap := CacheBitmap;
// Assign region for minimal overdraw
Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
SelectClipRgn(BufferDC, Region);
end
else
// Create buffer
BufferBitMap := CreateCompatibleBitmap(DC, RectWidth(UpdateRect), RectHeight(UpdateRect));
// Select buffer bitmap
SelectObject(BufferDC, BufferBitMap);
// [change coord], if need
// Moving update region to the (0,0) point
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
GetViewportOrgEx(BufferDC, SaveViewport);
SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
end;
end
else
BufferDC := DC;
end
else
BufferDC := DC;
//------------------------------------------------------------------------------------------------
end else
BufferDC := DC;
if not(csOpaque in ControlStyle) then
if ParentBackground then
begin
if FIsCachedBackground then
begin
if CacheBackground = 0 then
begin
TempDC := CreateCompatibleDC(DC);
CacheBackground := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
SelectObject(TempDC, CacheBackground);
DrawBackground(TempDC); //DrawParentImage(Self, TempDC, False);
DeleteDC(TempDC);
end;
TempDC := CreateCompatibleDC(BufferDC);
SelectObject(TempDC, CacheBackground);
if not FIsCachedBuffer then
BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY)
else
BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY);
DeleteDC(TempDC);
end
else
DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False);
end else
if (not DoubleBuffered or (DC <> 0)) then
if not IsStyledClientControl(Self) then
FillRect(BufferDC, ClientRect, Brush.Handle)
else
begin
SetDCBrushColor(BufferDC,
ColorToRGB({$ifdef VER230UP}StyleServices.GetSystemColor(Color){$else}Color{$endif}));
FillRect(BufferDC, ClientRect, GetStockObject(DC_BRUSH));
end;
FCanvas.Lock;
try
Canvas.Handle := BufferDC;
TControlCanvas(Canvas).UpdateTextFlags;
if Assigned(FOnPainting) then
FOnPainting(Self, Canvas, ClientRect);
Paint;
if Assigned(FOnPaint) then
FOnPaint(Self, Canvas, ClientRect);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
end;
finally
if BufferedThis then
begin
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintHandler, Please sync this code!!!
//------------------------------------------------------------------------------------------------
try
// draw to window
if not DoubleBuffered then
begin
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
// [restore coord], if need
SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
end
else
begin
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY);
end;
end;
finally
if BufferDC <> DC then
DeleteObject(BufferDC);
if Region <> 0 then
DeleteObject(Region);
// delete buffer, if need
if not FIsCachedBuffer and (BufferBitMap <> 0) then
DeleteObject(BufferBitMap);
end;
//------------------------------------------------------------------------------------------------
end;
end;
end;Буферизация вложенных TGraphicControl-ов реализована альтернативным методом PaintHandler, в котором происходит буферизация всех этапов прорисовки компонента, в том числе и отрисовки TGraphicControl-ов.
TEsCustomControl.PaintHandler
procedure TEsCustomControl.WMPaint(var Message: TWMPaint);
begin
ControlState := ControlState + [csCustomPaint];
if BufferedChildrens and (not FDoubleBuffered or (Message.DC <> 0)) then
begin
PaintHandler(Message)// My new PaintHandler
end
else
inherited;// WMPaint(Message);
ControlState := ControlState - [csCustomPaint];
end;
procedure TEsCustomControl.PaintHandler(var Message: TWMPaint);
var
PS: TPaintStruct;
BufferDC: HDC;
BufferBitMap: HBITMAP;
UpdateRect: TRect;
SaveViewport: TPoint;
Region: HRGN;
DC: HDC;
IsBeginPaint: Boolean;
begin
BufferBitMap := 0;
BufferDC := 0;
DC := 0;
Region := 0;
IsBeginPaint := Message.DC = 0;
try
if IsBeginPaint then
begin
DC := BeginPaint(Handle, PS);
{$IFDEF VER230UP}
if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
UpdateRect := ClientRect
// I had to use a crutch to ClientRect, due to the fact that
// VCL.Styles.TCustomStyle.DoDrawParentBackground NOT use relative coordinates,
// ie ignores SetViewportOrgEx!
// This function uses ClientToScreen and ScreenToClient for coordinates calculation!
else
{$endif}
UpdateRect := PS.rcPaint;
end
else
begin
DC := Message.DC;
{$IFDEF VER230UP}
if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
UpdateRect := ClientRect
else
{$endif}
if GetClipBox(DC, UpdateRect) = ERROR then
UpdateRect := ClientRect;
end;
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintWindow, Please sync this code!!!
//------------------------------------------------------------------------------------------------
// if control not double buffered then create or assign buffer
if not DoubleBuffered then
begin
BufferDC := CreateCompatibleDC(DC);
// CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
// return <> 0 => need to double buffer || return = 0 => no need to double buffer
if BufferDC <> 0 then
begin
// Using the cache if possible
if FIsCachedBuffer or FIsFullSizeBuffer then
begin
// Create cache if need
if CacheBitmap = 0 then
begin
BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
// Assign to cache if need
if FIsCachedBuffer then
CacheBitmap := BufferBitMap;
end
else
BufferBitMap := CacheBitmap;
// Assign region for minimal overdraw
Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
SelectClipRgn(BufferDC, Region);
end
else
// Create buffer
BufferBitMap := CreateCompatibleBitmap(DC,
UpdateRect.Right - UpdateRect.Left, UpdateRect.Bottom - UpdateRect.Top);
// Select buffer bitmap
SelectObject(BufferDC, BufferBitMap);
// [change coord], if need
// Moving update region to the (0,0) point
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
GetViewportOrgEx(BufferDC, SaveViewport);
SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
end;
end
else
BufferDC := DC;
end
else
BufferDC := DC;
//------------------------------------------------------------------------------------------------
// DEFAULT HANDLER:
Message.DC := BufferDC;
inherited PaintHandler(Message);
finally
try
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintWindow, Please sync this code!!!
//------------------------------------------------------------------------------------------------
try
// draw to window
if not DoubleBuffered then
begin
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
// [restore coord], if need
SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
end
else
begin
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY);
end;
end;
finally
if BufferDC <> DC then
DeleteObject(BufferDC);
if Region <> 0 then
DeleteObject(Region);
// delete buffer, if need
if not FIsCachedBuffer and (BufferBitMap <> 0) then
DeleteObject(BufferBitMap);
end;
//------------------------------------------------------------------------------------------------
finally
// end paint, if need
if IsBeginPaint then
EndPaint(Handle, PS);
end;
end;
end;Класс TEsCustomControl имеет несколько полезных свойств и событий:
TPaintEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect) of object;
/// <summary> The best replacement for TCustomControl, supports transparency and without flicker </summary>
TEsCustomControl = class(TWinControl)
...
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure UpdateBackground(Repaint: Boolean); overload;
procedure UpdateBackground; overload;
// ------------------ Properties for published -------------------------------------------------
property DoubleBuffered default False;
{$IFDEF VER210UP}
property ParentDoubleBuffered default False;
{$ENDIF}
// Painting for chidrens classes
property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
property OnPainting: TPaintEvent read FOnPainting write FOnPainting;
// BufferedChildrens
property ParentBufferedChildrens: Boolean read FParentBufferedChildrens write SetParentBufferedChildrens default True;
property BufferedChildrens: Boolean read FBufferedChildrens write SetBufferedChildrens stored IsBufferedChildrensStored;
// External prop
property IsCachedBuffer: Boolean read FIsCachedBuffer write SetIsCachedBuffer default False;
property IsCachedBackground: Boolean read FIsCachedBackground write SetIsCachedBackground default False;
property IsDrawHelper: Boolean read FIsDrawHelper write SetIsDrawHelper default False;
property IsOpaque: Boolean read GetIsOpaque write SetIsOpaque default False;
// property IsTransparentMouse: Boolean read FIsTransparentMouse write FIsTransparentMouse default False;
property IsFullSizeBuffer: Boolean read FIsFullSizeBuffer write FIsFullSizeBuffer default False;
end;Интересным может оказаться свойство IsDrawHelper рисующее удобную рамку в DesignTime.
Для создания своего не мерцающего компонента вам достаточно унаследоваться от 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;
BufferDC := 0;
DC := 0;
Region := 0;
IsBeginPaint := Message.DC = 0;
try
if IsBeginPaint then
begin
DC := BeginPaint(Handle, PS);
{$IFDEF VER230UP}
if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
UpdateRect := ClientRect
// I had to use a crutch to ClientRect, due to the fact that
// VCL.Styles.TCustomStyle.DoDrawParentBackground NOT use relative coordinates,
// ie ignores SetViewportOrgEx!
// This function uses ClientToScreen and ScreenToClient for coordinates calculation!
else
{$endif}
UpdateRect := PS.rcPaint;
end
else
begin
DC := Message.DC;
{$IFDEF VER230UP}
if TStyleManager.IsCustomStyleActive and not FIsCachedBuffer then
UpdateRect := ClientRect
else
{$endif}
if GetClipBox(DC, UpdateRect) = ERROR then
UpdateRect := ClientRect;
end;
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintWindow, Please sync this code!!!
//------------------------------------------------------------------------------------------------
// if control not double buffered then create or assign buffer
if not DoubleBuffered then
begin
BufferDC := CreateCompatibleDC(DC);
// CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
// return <> 0 => need to double buffer || return = 0 => no need to double buffer
if BufferDC <> 0 then
begin
// Using the cache if possible
if FIsCachedBuffer or FIsFullSizeBuffer then
begin
// Create cache if need
if CacheBitmap = 0 then
begin
BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
// Assign to cache if need
if FIsCachedBuffer then
CacheBitmap := BufferBitMap;
end
else
BufferBitMap := CacheBitmap;
// Assign region for minimal overdraw
Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
SelectClipRgn(BufferDC, Region);
end
else
// Create buffer
BufferBitMap := CreateCompatibleBitmap(DC,
UpdateRect.Right - UpdateRect.Left, UpdateRect.Bottom - UpdateRect.Top);
// Select buffer bitmap
SelectObject(BufferDC, BufferBitMap);
// [change coord], if need
// Moving update region to the (0,0) point
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
GetViewportOrgEx(BufferDC, SaveViewport);
SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
end;
end
else
BufferDC := DC;
end
else
BufferDC := DC;
//------------------------------------------------------------------------------------------------
// DEFAULT HANDLER:
Message.DC := BufferDC;
inherited PaintHandler(Message);
finally
try
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintWindow, Please sync this code!!!
//------------------------------------------------------------------------------------------------
try
// draw to window
if not DoubleBuffered then
begin
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
// [restore coord], if need
SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
end
else
begin
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY);
end;
end;
finally
if BufferDC <> DC then
DeleteObject(BufferDC);
if Region <> 0 then
DeleteObject(Region);
// delete buffer, if need
if not FIsCachedBuffer and (BufferBitMap <> 0) then
DeleteObject(BufferBitMap);
end;
//------------------------------------------------------------------------------------------------
finally
// end paint, if need
if IsBeginPaint then
EndPaint(Handle, PS);
end;
end;
end;
{$ifdef VER210UP} {$REGION 'BACKUP'}
(*
// Main magic located here:
procedure TESCustomControl.PaintWindow(DC: HDC);
var
BufferDC, TempDC: HDC;
BufferBitMap: HBITMAP;
UpdateRect: TRect;
SaveViewport: TPoint;
Region: HRGN;
begin
//UpdateRect := Rect(0, 0, Width, Height);
//GetClipBox(DC, UpdateRect);
if GetClipBox(DC, UpdateRect) = ERROR then
UpdateRect := Rect(0, 0, Width, Height);
if not DoubleBuffered then
begin
BufferDC := CreateCompatibleDC(DC);
// for bitmap context
if BufferDC = 0 then
BufferDC := DC
else
begin
if FCachedBuffer then
begin
if CacheBuffer = 0 then
CacheBuffer := CreateCompatibleBitmap(DC, Width, Height);
BufferBitMap := CacheBuffer;
Region := CreateRectRgn(0, 0, UpdateRect.Width, UpdateRect.Height);
SelectClipRgn(BufferDC, Region);
end
else
BufferBitMap := CreateCompatibleBitmap(DC, UpdateRect.Width, UpdateRect.Height);
SelectObject(BufferDC, BufferBitMap);
end;
end
else
BufferDC := DC;
// change coord
if (not DoubleBuffered){ and (not FCachedBuffer)} then
begin
GetViewportOrgEx(BufferDC, SaveViewport);
SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
end;
if not(csOpaque in ControlStyle) then
if ParentBackground then
begin
if FCachedBackground then
begin
if CacheBackground = 0 then
begin
TempDC := CreateCompatibleDC(DC);
CacheBackground := CreateCompatibleBitmap(DC, Width, Height);
SelectObject(TempDC, CacheBackground);
DrawParentImage(Self, TempDC, False);
DeleteDC(TempDC);
end;
TempDC := CreateCompatibleDC(BufferDC);
SelectObject(TempDC, CacheBackground);
BitBlt(BufferDC, 0, 0, UpdateRect.Width, UpdateRect.Height, TempDC, 0, 0, SRCCOPY);
DeleteDC(TempDC);
end
else
DrawParentImage(Self, BufferDC, False);
end else
if (not DoubleBuffered) then
FillRect(BufferDC, Rect(0, 0, Width, Height), Brush.Handle);
FCanvas.Lock;
try
Canvas.Handle := BufferDC;
TControlCanvas(Canvas).UpdateTextFlags;
Paint;
//Canvas.Brush.Color := Random(256*256*256);
//Canvas.FillRect(Updaterect);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
end;
if IsDrawHelper and(csDesigning in ComponentState) then
begin
SetBkColor(BufferDC, RGB(127,255,255));
DrawFocusRect(BufferDC, self.ClientRect);//self.ClientRect);// for Design
end;
// restore coord
if (not DoubleBuffered){ and (not FCachedBuffer)} then
SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
if not DoubleBuffered then
begin
if not FCachedBuffer then
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, UpdateRect.Width, UpdateRect.Height, BufferDC, 0, 0, SRCCOPY)
else
begin
//BitBlt(DC, UpdateRect.Left, UpdateRect.Top, UpdateRect.Width, UpdateRect.Height, BufferDC, UpdateRect.Left, UpdateRect.Top, SRCCOPY);
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, UpdateRect.Width, UpdateRect.Height, BufferDC, 0, 0, SRCCOPY);
DeleteObject(Region);
end;
DeleteDC(BufferDC);
end;
if not FCachedBuffer and (BufferBitMap <> 0) then DeleteObject(BufferBitMap);
end;
*)
{$ENDREGION} {$endif}
{ TODO -cMAJOR : 22.02.2013:
See: PaintHandler,
need eliminate duplication of code! }
procedure TEsCustomControl.PaintWindow(DC: HDC);
var
TempDC: HDC;
UpdateRect: TRect;
//---
BufferDC: HDC;
BufferBitMap: HBITMAP;
Region: HRGN;
SaveViewport: TPoint;
BufferedThis: Boolean;
begin
BufferBitMap := 0;
Region := 0;
BufferDC := 0;
if GetClipBox(DC, UpdateRect) = ERROR then
UpdateRect := ClientRect;
BufferedThis := not BufferedChildrens;
try
if BufferedThis then
begin
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintHandler, Please sync this code!!!
//------------------------------------------------------------------------------------------------
// if control not double buffered then create or assign buffer
if not DoubleBuffered then
begin
BufferDC := CreateCompatibleDC(DC);
// CreateCompatibleDC(DC) return 0 if Drawing takes place to MemDC(buffer):
// return <> 0 => need to double buffer || return = 0 => no need to double buffer
if BufferDC <> 0 then
begin
// Using the cache if possible
if FIsCachedBuffer or FIsFullSizeBuffer then
begin
// Create cache if need
if CacheBitmap = 0 then
begin
BufferBitMap := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
// Assign to cache if need
if FIsCachedBuffer then
CacheBitmap := BufferBitMap;
end
else
BufferBitMap := CacheBitmap;
// Assign region for minimal overdraw
Region := CreateRectRgnIndirect(UpdateRect);//0, 0, UpdateRect.Width, UpdateRect.Height);
SelectClipRgn(BufferDC, Region);
end
else
// Create buffer
BufferBitMap := CreateCompatibleBitmap(DC, RectWidth(UpdateRect), RectHeight(UpdateRect));
// Select buffer bitmap
SelectObject(BufferDC, BufferBitMap);
// [change coord], if need
// Moving update region to the (0,0) point
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
GetViewportOrgEx(BufferDC, SaveViewport);
SetViewportOrgEx(BufferDC, -UpdateRect.Left + SaveViewport.X, -UpdateRect.Top + SaveViewport.Y, nil);
end;
end
else
BufferDC := DC;
end
else
BufferDC := DC;
//------------------------------------------------------------------------------------------------
end else
BufferDC := DC;
if not(csOpaque in ControlStyle) then
if ParentBackground then
begin
if FIsCachedBackground then
begin
if CacheBackground = 0 then
begin
TempDC := CreateCompatibleDC(DC);
CacheBackground := CreateCompatibleBitmap(DC, ClientWidth, ClientHeight);
SelectObject(TempDC, CacheBackground);
DrawBackground(TempDC); //DrawParentImage(Self, TempDC, False);
DeleteDC(TempDC);
end;
TempDC := CreateCompatibleDC(BufferDC);
SelectObject(TempDC, CacheBackground);
if not FIsCachedBuffer then
BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY)
else
BitBlt(BufferDC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), TempDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY);
DeleteDC(TempDC);
end
else
DrawBackground(BufferDC); //DrawParentImage(Self, BufferDC, False);
end else
if (not DoubleBuffered or (DC <> 0)) then
if not IsStyledClientControl(Self) then
FillRect(BufferDC, ClientRect, Brush.Handle)
else
begin
SetDCBrushColor(BufferDC,
ColorToRGB({$ifdef VER230UP}StyleServices.GetSystemColor(Color){$else}Color{$endif}));
FillRect(BufferDC, ClientRect, GetStockObject(DC_BRUSH));
end;
FCanvas.Lock;
try
Canvas.Handle := BufferDC;
TControlCanvas(Canvas).UpdateTextFlags;
if Assigned(FOnPainting) then
FOnPainting(Self, Canvas, ClientRect);
Paint;
if Assigned(FOnPaint) then
FOnPaint(Self, Canvas, ClientRect);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
end;
finally
if BufferedThis then
begin
//------------------------------------------------------------------------------------------------
// Duplicate code, see PaintHandler, Please sync this code!!!
//------------------------------------------------------------------------------------------------
try
// draw to window
if not DoubleBuffered then
begin
if not(FIsCachedBuffer or FIsFullSizeBuffer) then
begin
// [restore coord], if need
SetViewportOrgEx(BufferDC, SaveViewport.X, SaveViewport.Y, nil);
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC, 0, 0, SRCCOPY);
end
else
begin
BitBlt(DC, UpdateRect.Left, UpdateRect.Top, RectWidth(UpdateRect), RectHeight(UpdateRect), BufferDC,
UpdateRect.Left, UpdateRect.Top, SRCCOPY);
end;
end;
finally
if BufferDC <> DC then
DeleteObject(BufferDC);
if Region <> 0 then
DeleteObject(Region);
// delete buffer, if need
if not FIsCachedBuffer and (BufferBitMap <> 0) then
DeleteObject(BufferBitMap);
end;
//------------------------------------------------------------------------------------------------
end;
end;
end;
function TEsCustomControl.IsBufferedChildrensStored: Boolean;
begin
Result := not ParentBufferedChildrens;
end;
procedure TEsCustomControl.SetBufferedChildrens(const Value: Boolean);
begin
if Value <> FBufferedChildrens then
begin
FBufferedChildrens := Value;
FParentBufferedChildrens := False;
NotifyControls(CM_PARENT_BUFFEREDCHILDRENS_CHANGED);
end;
end;
procedure TEsCustomControl.SetIsCachedBackground(Value: Boolean);
begin
if Value <> FIsCachedBackground then
begin
FIsCachedBackground := Value;
if not FIsCachedBackground then BitMapDeleteAndNil(CacheBackground);
end;
end;
procedure TEsCustomControl.SetIsCachedBuffer(Value: Boolean);
begin
if Value <> FIsCachedBuffer then
begin
FIsCachedBuffer := Value;
if not FIsCachedBuffer then BitMapDeleteAndNil(CacheBitmap);
end;
end;
procedure TEsCustomControl.SetIsDrawHelper(const Value: Boolean);
begin
FIsDrawHelper := Value;
if csDesigning in ComponentState then Invalidate;
end;
procedure TEsCustomControl.SetIsOpaque(const Value: Boolean);
begin
if Value <> (csOpaque in ControlStyle) then
begin
if Value then
begin
ControlStyle := ControlStyle + [csOpaque];
end else
begin
ControlStyle := ControlStyle - [csOpaque];
end;
Invalidate;
end;
end;
procedure TEsCustomControl.SetParentBufferedChildrens(const Value: Boolean);
begin
//FParentBufferedChildrens := Value;
if Value <> FParentBufferedChildrens then
begin
// if (Parent <> nil) and Value then
// begin
// if Parent is TESCustomControl then
// BufferedChildrens := TESCustomControl(Parent).BufferedChildrens
// else
// BufferedChildrens := False;
// end
// else
// if Value then
// BufferedChildrens := False;
// FParentBufferedChildrens := Value;
FParentBufferedChildrens := Value;
if (Parent <> nil) and not (csReading in ComponentState) then
Perform(CM_PARENT_BUFFEREDCHILDRENS_CHANGED, 0, 0);
end;
end;
procedure TEsCustomControl.SetTransparent(const Value: Boolean);
begin
ParentBackground := Value;
end;
procedure TEsCustomControl.UpdateBackground;
begin
UpdateBackground(True);
end;
procedure TEsCustomControl.UpdateText;
begin
end;
procedure TEsCustomControl.UpdateBackground(Repaint: Boolean);
begin
// Delete cache background
if CacheBackground <> 0 then BitMapDeleteAndNil(CacheBackground);
if Repaint then Invalidate;
end;
procedure TEsCustomControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
if DoubleBuffered {and not(csOpaque in ControlStyle)} then
begin
Inherited;
Message.Result := 1;
exit;
end;
if ControlCount <> 0 then
DrawBackgroundForOpaqueControls(Message.DC);
Message.Result := 1;
end;
//procedure TEsCustomControl.WMNCHitTest(var Message: TWMNCHitTest);
//begin
// if (FIsTransparentMouse) and not(csDesigning in ComponentState) then
// Message.Result := HTTRANSPARENT
// else
// inherited;
//end;
procedure TEsCustomControl.WMPaint(var Message: TWMPaint);
begin
ControlState := ControlState + [csCustomPaint];
if BufferedChildrens and (not FDoubleBuffered or (Message.DC <> 0)) then
begin
PaintHandler(Message)// My new PaintHandler
end
else
inherited;// WMPaint(Message);
ControlState := ControlState - [csCustomPaint];
end;
procedure TEsCustomControl.WMSize(var Message: TWMSize);
begin
DeleteCache;
inherited;
end;
procedure TEsCustomControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
if not (csOpaque in ControlStyle) and ParentBackground{ and not CachedBackground }then
Invalidate;
Inherited;
end;
{$IFDEF VER180UP}
{ TEsBaseLayout }
procedure TEsBaseLayout.AdjustClientRect(var Rect: TRect);
begin
inherited AdjustClientRect(Rect);
if BorderWidth <> 0 then
begin
InflateRect(Rect, -Integer(BorderWidth), -Integer(BorderWidth));
end;
end;
procedure TEsBaseLayout.AlignControls(AControl: TControl; var Rect: TRect);
begin
inherited AlignControls(AControl, Rect);
if (csDesigning in ComponentState) and IsDrawHelper then
Invalidate;
end;
procedure TEsBaseLayout.CalcContentMargins(var Margins: TContentMargins);
begin
Margins.Create(Padding.Left, Padding.Top, Padding.Right, Padding.Bottom);
if BorderWidth <> 0 then
Margins.Inflate(Integer(BorderWidth), Integer(BorderWidth));
end;
function TEsBaseLayout.ContentMargins: TContentMargins;
begin
Result.Reset;
CalcContentMargins(Result);
end;
function TEsBaseLayout.ContentRect: TRect;
var
ContentMargins: TContentMargins;
begin
Result := ClientRect;
ContentMargins.Reset;
CalcContentMargins(ContentMargins);
Inc(Result.Left, ContentMargins.Left);
Inc(Result.Top, ContentMargins.Top);
Dec(Result.Right, ContentMargins.Right);
Dec(Result.Bottom, ContentMargins.Bottom);
{$ifdef TEST_CONTROL_CONTENT_RECT}
if Result.Left > Result.Right then
Result.Right := Result.Left;
if Result.Top > Result.Bottom then
Result.Bottom := Result.Top;
{$endif}
end;
procedure TEsBaseLayout.Paint;
begin
if (csDesigning in ComponentState) and IsDrawHelper then
DrawControlHelper(Self, [hoBorder, hoPadding, hoClientRect]);
end;
procedure TEsBaseLayout.SetBorderWidth(const Value: TBorderWidth);
begin
if Value <> FBorderWidth then
begin
FBorderWidth := Value;
Realign;
Invalidate;
end;
end;
{ TEsGraphicControl }
procedure TEsGraphicControl.CalcContentMargins(var Margins: TContentMargins);
begin
if FPadding <> nil then
Margins.Create(Padding.Left, Padding.Top, Padding.Right, Padding.Bottom)
else
Margins.Reset;
end;
function TEsGraphicControl.ContentMargins: TContentMargins;
begin
Result.Reset;
CalcContentMargins(Result);
end;
function TEsGraphicControl.ContentRect: TRect;
var
ContentMargins: TContentMargins;
begin
Result := ClientRect;
ContentMargins.Reset;
CalcContentMargins(ContentMargins);
Inc(Result.Left, ContentMargins.Left);
Inc(Result.Top, ContentMargins.Top);
Dec(Result.Right, ContentMargins.Right);
Dec(Result.Bottom, ContentMargins.Bottom);
{$ifdef TEST_CONTROL_CONTENT_RECT}
if Result.Left > Result.Right then
Result.Right := Result.Left;
if Result.Top > Result.Bottom then
Result.Bottom := Result.Top;
{$endif}
end;
destructor TEsGraphicControl.Destroy;
begin
FPadding.Free;
inherited;
end;
function TEsGraphicControl.GetPadding: TPadding;
begin
if FPadding = nil then
begin
FPadding := TPadding.Create(nil);
FPadding.OnChange := PaddingChange;
end;
Result := FPadding;
end;
function TEsGraphicControl.HasPadding: Boolean;
begin
Result := FPadding <> nil;
end;
procedure TEsGraphicControl.PaddingChange(Sender: TObject);
begin
AdjustSize;
Invalidate;
if (FPadding.Left = 0) and (FPadding.Top = 0) and (FPadding.Right = 0) and (FPadding.Bottom = 0) then
FreeAndNil(FPadding);
end;
procedure TEsGraphicControl.Paint;
begin
if (csDesigning in ComponentState) and IsDrawHelper then
DrawControlHelper(Self, [hoPadding, hoClientRect]);
end;
procedure TEsGraphicControl.SetIsDrawHelper(const Value: Boolean);
begin
if FIsDrawHelper <> Value then
begin
FIsDrawHelper := Value;
if csDesigning in ComponentState then
Invalidate;
end;
end;
procedure TEsGraphicControl.SetPadding(const Value: TPadding);
begin
Padding.Assign(Value);
end;
{ TContentMargins }
constructor TContentMargins.Create(Left, Top, Right, Bottom: TMarginSize);
begin
Self.Left := Left;
Self.Top := Top;
Self.Right := Right;
Self.Bottom := Bottom;
end;
procedure TContentMargins.Reset;
begin
Left := 0;
Top := 0;
Right := 0;
Bottom := 0;
end;
function TContentMargins.Height: TMarginSize;
begin
Result := Top + Bottom;
end;
procedure TContentMargins.Inflate(DX, DY: Integer);
begin
Inc(Left, DX);
Inc(Right, DX);
Inc(Top, DY);
Inc(Bottom, DY);
end;
procedure TContentMargins.Inflate(DLeft, DTop, DRight, DBottom: Integer);
begin
Inc(Left, DLeft);
Inc(Right, DRight);
Inc(Top, DTop);
Inc(Bottom, DBottom);
end;
function TContentMargins.Width: TMarginSize;
begin
Result := Left + Right;
end;
{$ENDIF}
end.Но лучше использовать бесплатную библиотеку VCL компонентов EsVclComponents, которая содержит в себе данные модули и еще много интересных компонентов и классов:
https://github.com/errorcalc/FreeEsVclComponents (библиотека также доступна в пакетном менеджере GetIt для Delphi Berlin, правда не самая свежая версия).
Посмотрите примеры, особенно "\Samples\BufferedChildrens", где видно "магию" подавления мерцания.
Возможно стоит написать отдельную обзорную статью о данной библиотеке?
Спасибо что дочитали статью до конца! Надеюсь, я помог вам побороть проблему мерцания в ваших приложениях и компонентах.
Вы можете помочь проекту, написав мне, где вы используете данные компоненты и приложив скриншот с примером использования.
Поделиться с друзьями
Комментарии (88)
engune
06.01.2017 20:27+2В свое время пользовался Delphi разных версий 3, 4, 5, 6. Большую часть делал интерфейсы, кастомные контролы и псевдо 3D на cos и sin. Были времена, приятно вспомнить.
alexkunin
06.01.2017 20:29+2Очень плохо помню, но кажется лет 15 назад все такие проблемы решались перехватом WM_ERASEBKGND и недопуском его дефольтного обработчика, который затирал весь контрол красивым серым цветом. В случае ВЦЛ-компонент, это относится к первому родителю с HWND, «виртуальные» дети которого рисовали сами себя по уже нарисованному.
При неосторожной отрисовке могли быть артефакты, особенно при перемещении и изменении размера окна. А также с появлением (человеческой реализации) сглаживания шрифтов в винде — частный «глюк»: перерисовываемый текст со сглаживанием становился все жирнее и неразборчивей из-за постоянного наслоения. Зато проблема решалась в одном месте на все приложение.
Вроде бы ваше решение от такого не страдает (честная отрисовка в невидимый буфер), но вы форсируете «папу» «напечататься» (WM_PRINTCLIENT), а это может иметь побочные эффекты. Лет адцать назад я встречал контролы, которые не давали «печататься» — чтобы нельзя было сделать, скажем, слепок с защищенной пдфки, которую контрол демонстрирует.dmitryredkin
06.01.2017 20:44-1Плюсую WM_ERASEBKGND.
Изучать надо WinAPI, тогда и проблем не будет.
Работаю с OWL/VCL более 20 лет. Про «проблему мерцания» слышу в первый раз.
Error1024
06.01.2017 20:52+6Откройте стандартный «диспетчер устройств» и попробуйте изменять размер окна, оцените мерцание.
В VCL также, посмотрите на саму Rad Studio.
Error1024
06.01.2017 20:47-1но вы форсируете «папу» «напечататься» (WM_PRINTCLIENT), а это может иметь побочные эффекты. Лет адцать назад я встречал контролы, которые не давали «печататься» — чтобы нельзя было сделать, скажем, слепок с защищенной пдфки, которую контрол демонстрирует.
Как я уже писал, класс показал свою надежную работу :)
Но для таких «кривоватых» контролов я сделал виртуальный метод procedure DrawBackground(DC: HDC); virtual;, в котором для обхода проблем подобных компонентов можно переопределить отрисовку фона.
Кроме того компонент имеет множество настроек буферизации.
tsklab
06.01.2017 20:32-2Про мерцание уже забыл по двум причинам: не использую большое количество контролов на форме и, наоборот, использую дискретные видео-карты и хорошим 2D-рендерингом.
Error1024
06.01.2017 20:41+2К сожалению начиная с Windows Vista, GDI практически перестало использовать 2д ускорение, и к сожалению проблема мерцания никуда не ушла, да о чем говорить — многие стандартные Windows приложения мерцают.
Fortop
07.01.2017 18:02Блин, вы о чем?
Что за мерцание?
Пример такого стандартного Windows приложения и как это самое мерцание воспроизвести?
Error1024
07.01.2017 18:08+1Как я уже писал: «Откройте стандартный «диспетчер устройств» и попробуйте изменять размер окна, оцените мерцание.».
Fortop
07.01.2017 18:14Windows 10
Открыл Device Manager — ничего не мерцает, как я ни меняю размер окна.
С какой частотой и как быстро его надо менять?Error1024
07.01.2017 18:25+1Важно чтобы было не было отключено «Отображать содержимое окна при перетаскивании».
Можно еще открыть «Управление компьютером» и полистать там вкладки.Fortop
07.01.2017 19:52Ну предположим, что я совсем идиот, и флаг "отображать содержимое" у меня был отключен.
Проблема в том, что он был включён и поведение не воспроизводилось.
Аналогично с вкладками компьютера.
Вы можете уточнить свою конфигурацию, на которой вы это воспроизводите?
TheRaven
08.01.2017 14:18+1Win7, открываю диспетчер задач и начинаю его ресайзить туда-сюда: мерцают верхние вкладки.
agranom555
08.01.2017 15:35Последняя стабильная Windows 10. При изменении размера влево вправа мерцает. Не каждое изменение, но мерцает. Попробуйте секунд 5 изменять и увидите
stychos
08.01.2017 18:13+1Вы сузьте окно так, чтобы оно закрывало часть верхних вкладок, потом расширяйте — мерцание вкладок обеспечено.
AndrewTishkin
10.01.2017 17:54Я бы в качестве ещё одного примера привёл окно проводника. Особенно момент уменьшения до размера, когда пропадает риббон
msts2017
06.01.2017 21:18странно что вообще проблема с мерцанием еще есть, всмысле, ведь ее решили на уровне винды — «композитор» с висты работает с двойной буферизацией в принципе.
Error1024
06.01.2017 21:22+2«композитор» решает проблему композиции только окон верхнего уровня.
msts2017
06.01.2017 21:30-2и? как раз для этого он держит буфер для каждого окна и туда пишутся все команды отрисовки а потом результат выводится, мерцание возможно только если дать команду заставляющую «композитор»отрисовать окно на экране.
да и вообще, прежде чем написать, я проверил — с выключенными темами мерцает с включенными нет.Error1024
06.01.2017 21:33+3Как я уже писал: «Откройте стандартный «диспетчер устройств» и попробуйте изменять размер окна, оцените мерцание.».
Возможно у вас быстрая машина и вы не успеваете заметить мерцание, или приложение на котором вы проверяете буферизирует отрисовку.
msts2017
06.01.2017 21:36т.е. по хорошему, двойную буферизацию надо отключать когда программу по RDP запустили а с висты еще когда темы включены, как-то так.
Error1024
06.01.2017 21:39+2Повторяю — проблема мерцания в классических WinApi приложениях никуда не исчезла, те что не мерцают — сами буферизируют отрисовку или вообще используют один из фреймворков для GUI.
perfect_genius
06.01.2017 21:39+8А если моргать синхронно с мерцанием, то мерцание вообще не увидеть =)
VaalKIA
06.01.2017 22:47Поднадоели исходники С# и C++ в функциональном стиле, как приятно видеть старый добрый Паскаль, только из-за этого прочёл всю статью, да и в общем-то актуальная тема, но не хватает гифок. Ещё бы с Russian AI CUP какой-нибудь Дельфист выложил мемуары, вообще было бы шикарное начало года.
Klenov_s
06.01.2017 22:52+3Очень хотелось почитать какие-нить свежие статьи по free-pascal или delphi, но устранением мерцания в VCL я занимался лет 18-20 назад. Неужели ничего нового с тех пор не возникло?
Error1024
06.01.2017 22:58Проблема мерцания и прозрачности все еще актуальна, по причине актуальности VCL, который базируется на довольно консервативном WinApi.
Новое есть — если про VCL, то теперь есть поддержка юникода, скинов.
Появился новый интерфейсный фреймворк — FMX, а с ним и поддержка MacOS, Android, iOS.
В следующем релизе будет серверный Linux.
Ну и кончено же в языке много изменений произошло.
Smi1e
07.01.2017 02:17Если позволите, небольшое замечание по имени переменной
Класс имеет свойство BufferedChildrens
Используйте Childs или Children (а еще лучше глагол: BufferChilds). Слова Childrens не существует, ибо Children — уже множественное число.Error1024
07.01.2017 02:40Да, есть ошибка, знаю, но исправить «легко и просто» нельзя к сожалению, это сломает много кода(не моего).
Но я знаю как можно в течении времени исправить, добавив правильный «двойник» свойства, скрыть в дизайнере неправильное свойство через ToolsApi и т.д., при этом из dfm будет считываться неверное свойство, а записываться будет верное свойство. Если возможно будет исправить не сломав совместимость, то будет исправлено.
alex_ter
07.01.2017 02:24+1Небольшое отступление. В MS видимо в курсе проблемы, но для приложений, использующих классический API (в т.ч. это большинство системных) видимо нормального решения нет. Именно по-этому для классов ListView и TreeView они добавили встроенную двойную буферизацию, которая работает явно лучше, предложенной в VCL.
См. TVS_EX_DOUBLEBUFFER и LVS_EX_DOUBLEBUFFER.Error1024
07.01.2017 02:32Согласен, у меня в EsVclComponents есть модуль специальный, который включает «родную» буферизацию для TListView: ES.VclFix.pas
Его достаточно подключить в файле с формой :)
Maccimo
07.01.2017 08:20+3{$ifdef VER210UP} {$REGION 'BACKUP'} (* // Main magic located here: procedure TESCustomControl.PaintWindow(DC: HDC); var BufferDC, TempDC: HDC; BufferBitMap: HBITMAP; UpdateRect: TRect; SaveViewport: TPoint; Region: HRGN; begin
Зачем вам система контроля версий, если вы продолжаете хранить полуразложившиеся трупы в комментариях?
alan008
07.01.2017 11:56+2(я не автор поста) Иногда удаленный код удобно оставлять в комментариях, чтобы видеть его происхождение через blame/diff. Иначе отследить, что тут когда-то давно был какой-то код, довольно сложно
DrPass
07.01.2017 13:13+3Ну потому что если код может вызвать вопросы «откуда это произошло», ответ лучше оставить рядом с кодом, а не заставлять каждого вопрошающего заниматься прикладной археологией в системе контроля версий.
kovserg
07.01.2017 13:57На сколько я помню всё можно было буферизировать кроме richedit эта редиска плевать хотела на dc который ей передают и вместо текста получалась дырка от бублика. Вы смогли это победить?
sim31r
07.01.2017 16:25-1Иногда использую вариант такой
memo1.visible.false
// много изменений в сожержимом
memo1.visible.true
нет ни мерцания, и задержка на обращение к компоненту снижается по времени раз в 10, придумал такое «методом тыка». Может кому-то пригодится тоже.Error1024
07.01.2017 16:52+2Настоятельно не рекомендую пользоваться таким способом, вам «повезло» что он работает, но нет никаких гарантий что не сломается или не даст необычные глюки.
Используйте:
Memo1.Lines.BeginUpdate; try // изменения finally Memo1.Lines.EndUpdate; end;sim31r
07.01.2017 17:08-1Да, ваш метод лучше. Глюки могут быть, если задержать процесс обновления, компонент просто исчезнет с экрана. Например, при обращении к БД. Только для быстрых изменений, добавления уже готовых данных.
SBC
07.01.2017 22:14+2Специально попробовал ваш способ (думал магия есть).
Мерцания пропало (как и ожидалось), но теперь получился просто исчезающий и появляющийся компонент.
По мне так лучше будет мерцание, чем моргание всем компонентом ))sim31r
08.01.2017 03:19-1В моем случае, он не успевает моргать, и время процессора не тратится на перерисовку, пример
memo1.visible.false
memo1.lines.add('test'); // много изменений
memo1.clear;
memo1.lines.add('test');
memo1.lines.add('test');
memo1.visible.true
Но, конечно, метод с BeginUpdate делает всё это лучше.
pascualle
08.01.2017 21:21+2Ого! Вот это зачет!
Помню, сколько я часов провел на форумах, применяя всякие уловки против мерцания… Честно признаюсь, я в то время так и не нашел годного решения. Потому данная статья вызвала лично мне приятную ностальгию, а автору — реальное уважение.
Я когда-то около трех лет работал с VCL, правда на CBuilder. Задачей было организовать автоматизацию с красивым интерфейсом быстрыми темпами в одном банке. На то время лучшего решения чем Delphi5/CBuilder5 (кому что нравилось) попросту не было. Вот, столько лет прошло, а наши программы до сих пор нормально и успешно там работают без всякого саппорта.
Теперь же, работая чуть в другой сфере, отойдя от оконных приложений, мне лично, особенно когда надо «нафигачить что-то под винду с окнами побырику» кроме RADStudio я ничего не хочу знать, он меня устраивает всем. На CBuilder, к примеру, я пишу редактор уровней для своего движочка. Правда, чтобы избавиться от мерцания основного поля, я полностью отказался от TCanvas в его классическом применении, рендерю в него прямо OpenGL контекст.
Darthman
09.01.2017 13:11+2Спасибо за статью. У меня были свои методы борьбы с таким, но как правило с собственными контролами. Стандартные почти всегда работали вполне приемлемо и так. А сейчас я вообще в делфи ушел в геймдев, поэтому совсем неактуально стало. Но всё-равно любопытно.
ZblCoder
09.01.2017 13:29+2Спасибо за статью, часто борюсь с тем или иным мерцанием в своих компонентах. Какие только пути не изобретал.
A-Stahl
>Delphi… C++Builder… VCL
Бедняжка… За что тебя так? Ты хоть адрес напиши — мы тут тебе передачку соберём. Пару бутылок пива, сигареты, gcc, какую-то IDE…
Error1024
Минусанул тебе карму, ибо достали уже такие «знатоки».
Daar
Согласен. Досих пор использую Delphi 7 которую купил лет еще 15 назад (как то даже диск на глаза попадался :) ). Не спорю это не основная среда разработки, но если надо реально за 30 минут накидать виндовое приложение и которое будет работать практически везде и кроме переноса exe-файла ничего не требует (BDE не использую :) ), то это идеальна вещь. Некоторые проги написанные 10 лет назад все еще работают у людей и они их меня не хотят.
И чего душой кривить, вот 30 числа нужно было срочно написать конвертор для больших файлов для отправки в ЕГАИС… реально 20 минут и готово.
Danik-ik
Нам, дельфистам, некогда курить и пить пиво — работы много. И если честно, не видно внятных альтернатив для решения конкретного ряда задач.
К примеру: система финансово-управленческого учёта специального назначения, Windows native (требование спорное, но оно есть), ничего лишнего, максимальная эргономика с защитой от дурака и зловреда, минимальное время реакции на изменяющиеся требования бизнеса, минимальные требования к инфраструктурному обеспечению (типа ничего, кроме sql сервера).
Предложите альтернативу, я рассмотрю. Честно-честно. Давно хочу альтернативу.
A-Stahl
>Предложите альтернативу, я рассмотрю.
Qt+cpp;
Кроссплатформенность, поддержка современных компиляторов…
Если бы автор написал «Lazarus», то я слова бы не сказал. Паскаль так паскаль. Но Дельфи…
Я даже не удивлён такой негативной реакции на мою безобидную шутку — уверен, что над вами, дельфистами, смеются все и всегда. Вы уже, похоже, не в состоянии понимать шутки, а про самоиронию вы забыли ещё в 2000х.
DrPass
Это в лучшем случае шило на мыло. Ну т.е. если вы знаете C++, и вам нужна среда быстрой разработки толстых, но нативных приложений, то Qt для вас вполне годится. Но мигрировать на неё с Delphi, это просто головная боль, куча времени на поиск новых граблей, и ноль преимуществ в итоге.
A-Stahl
Гхм. А Дельфи нынче какой версии используется? Что его компилятор знает про современные процессоры?
Ничего? Ну это же никому не нужно, правильно?
Оптимизации? Какие оптимизации? Прогресс в этом направлении остановился в 2008, не так ли. (Нет, прогресс не остановился? Вы кормите мудаков из Эмбракадеро? Ну кто-то же должен кормить мудаков...)
Qt слишком толстый? Что, есть ещё виндовые машины где лишние 8-9МиБ слишком чувствительны? Впрочем, сомневаюсь, что футпринт дельфи значительно меньше.
Но даже если Qt слишком толстый, то есть GTK. Он куда более худой.
P.S. Обиженки с головной болью слили карму, так что я буду отвечать довольно редко. (Кстати, что же нужно иметь в голове, чтобы затыкать человеку рот на целом сайте? Боль, вероятно… и похоже нифига не головную, а ближе к точке возгорания:) )
Error1024
Извини, но ты мудак ;)
На остальное отвечать тебе не вижу смысла.
Поразительно то, что к каждой статье про Delphi найдется такой мудак, не способный пройти мимо. Благо теперь стали минусовать их.
torf2505
Не стоит опускаться до их уровня…
an24
Я тоже чего-то не понял, почему компилятор Delphi, по вашему мнению, не развивается? И вообще возникло сомнения, — а знаете ли вы что представляют собой современная версия Delphi?
torf2505
Убеждать апологетов — бесполезно
ZblCoder
В своё время, ко мне на стримы заходили толпы людей, и пытались убедить, что Delphi умер и стоит разрабатывать на других языках. При этом никто не мог обосновать свою логику. Некоторые уходили с пониманием, некоторые шли искать других, чтобы склонять в свою веру.
DrPass
Так, чисто для справки: коммерческая лицензия на Qt стоит порядка $150/месяц.
A-Stahl
>коммерческая лицензия на Qt стоит
Вот только покупать её нужно в исключительнейших случаях. В основном тогда, когда необходимо внести правки в сам код Qt или когда кровь из носа нужна статическая линковка. Остальным хватает LGPL и динамической линковки за бесплатно.
Сравнение ещё менее корректно хотя бы уже потому, что в код Дельфи внести изменения вообще невозможно (В жизни не поверю что жлобо-рептилоиды из эмбракадеро открыли код).
Error1024
Вообще-то исходный код RTL, VCL, FMX входит в поставку.
stychos
Ага, или элементарно захотеть статическую компиляцию, чтобы не распространять приложение с тоннами говна.
Darthman
А Starter версия делфи нынче вообще бесплатна, да. И уже давно принадлежит конторе с назнваием IDERA. Тоже так, чисто для справки.
torf2505
Бесплатны почти все образовательные лицензии…
Darthman
До осени того года стартер был 300+ баксов. Я в своё время ХЕ5 покупал тысяч за 8 рублей…
sborisov
На Qt будет дольше, с БД работать если и что-то кастомизировать, нужно написать модельки свои, делегатики. В Дельфи это займёт 5 минут мышекликаньем. RAD конечно лучше, чем в Дельфи никто не сделал.
Error1024
Шутка не должна выглядеть так, было неприятно получить «это» в качестве первого комментария вместо обоснованной критики под своей статьей, тебя заминусовали за это, и не только дельфисты.
А оправдываться что в случае лазаруса ты бы не оставил здесь свой «полезный» комментарий не стоит.
sasha1024
Взгляд со стороны — это тупая шутка.
A-Stahl
Шутка отличная, но ты просто не можешь посмотреть со стороны.
sasha1024
Об этом судить не автору шутки.
geher
Единственным реальным конкурентом Delphi (в старом понимании сего бренда, сейчас это дело объединили под общим названием) я назвал бы CBuilder, который использует тот же способ быстрой разработки приложений. Но на C++ RAD технология (если правильно помню ее наименование) ложится из-за особенностей языка гораздо хуже.
sborisov
С теплотой вспоминаю эти среды разработки.
Часто встречались на форумах претензии к качеству компилятора у билдера особенно на работу с ссылками. Но по скорости разработки, я в 90х писал и на Дельфи и на Билдере, разницы в принципе никакой не было, на билдере всё было так же быстро и приятно.
Жаль, что не сделали среду под Линукс нормальную. (Kylix) так и не взлетел, компилятор вроде не исправили, после перехода на ядро 2.4.18 — помнится, поменяли формат ELF файлов, а Борланду было уже не до него.
ElectroGuard
Линукс собираются на Делфи вновь возродить. Ждём. Лазарь, к слову, уже давно и успешно на линуксе работает и программы на нем пишутся.
Tom910
Что будете делать, если нужно будет сделать приложение для mac os или мобильных устройств? Я вижу только альтернативу в веб приложениях js/scalajs/clojurescript + react/angular 2 + electron/cordova. Везде работает, одна кодовая база.
DrPass
Delphi, как и большинство других современных средств разработки, давно позволяет делать приложения и для мобильных устройств, и для macOS. Надо иметь в виду, что у Delphi немного иная ниша, чем у веб-приложений. Delphi чаще всего используют для разработки бизнес-приложений, где чаще всего предполагается какая-либо активная работа с БД. «Фишка» Delphi, которая с ней была изначально, это удобные биндинги к базам данных и data-aware контролы, особенно гриды. В веб-платформах, к сожалению, ничего столь мощного нет в силу ограничений, накладываемых броузерами (ближе всего подобрался devExpress, но там другие нюансы есть). Поэтому потребность делать мобильные клиенты на Delphi не так часто бывает востребованной. Да и, честно говоря, далеко не всегда выгоднее иметь одну кодовую базу и слои адаптации под разные платформы, чем иметь несколько различных клиентов, каждый из которых оптимизирован под свою платформу.
ElectroGuard
Делфи сейчас работает на всех основных платформах — Win32/64, iOS, Android, MacOS, серверный линукс почти сделали. Собранный код по производительности может и проигрывает плюсам в некоторых случаях, но большинство частей библиотек хорошо оптимизированы ассемблером.
У Лазаруса список поддерживаемых платформ вообще огромен. При том, что он бесплатный, и последние сборки, например, отсюда: https://www.getlazarus.org вполне пригодны для работы. Есть биндинги Qt и Gtk, под виндой и линуксом. Так что для того, что бы работать с Qt совсем не обязательно переходить на плюсы.
JS, который мы тоже используем, сильно ограничен рамками браузера. Некоторые банальные вещи — например — копирование в буфер в нём сделать просто нельзя. Многие вещи браузеро-зависимые. То есть — получается не просто платформы, а куча браузеров на множестве платформ. Мы активно используем HMLT5, многопоточную обработку, WebGL. У разных браузеров на разных платформах свои особенности. Вместо написания функциональности приходится постоянно заниматься оптимизацией под браузеры.
serbod
http://www.unigui.com
Платная, да. По цене смартфона. Есть и бесплатные варианты, например http://www.morfik.com
Есть backend-фреймворки — https://github.com/silvioprog/brookframework
VVizard
Как вариант платформа 1С 8.3.х. (про цену лицензий в требованиях ничего не было :)). Но если система большая то цена лицензий в стоимости системы занимает от силы 1% ну и Delphi тоже не бесплатная.
По остальным показателям именно в «финансово-управленческом учёте» 1С вполне способна составить конкуренцию Delphi.
А если нужно и «минимальное время реакции на изменяющиеся требования бизнеса» то delphi сильно отстает от 1С.
RoseWoodsAlloy
а таки ваше гецэцэ умеет вицээль? А поддерживать старое легаси писанное и переписанное на дельфях как на гэцеце? Ах да, Reference counting и DCOM+ из коробочки, выньте да положте, пожалуйста…