unit MyAcceleratedPaintBox;
interface
uses
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Direct2D, D2D1, Winapi.Windows,
Winapi.Messages, Vcl.ExtCtrls;
type
TCustomAcceleratedPaintBox = class(TCustomControl)
private
FOnPaint: TNotifyEvent;
FUseD2D: Boolean;
FD2DCanvas: TDirect2DCanvas;
function CreateD2DCanvas: Boolean;
{ Catching paint events }
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
{ Set/Get stuff }
procedure SetAccelerated(const Value: Boolean);
function GetGDICanvas: TCanvas;
function GetOSCanvas: TCustomCanvas;
protected
procedure CreateWnd; override;
procedure Paint; override;
public
{ Life-time management }
constructor Create(AOwner: TComponent); override;
destructor Destroy(); override;
{ Public properties }
property Accelerated: Boolean read FUseD2D write SetAccelerated;
property Canvas: TCustomCanvas read GetOSCanvas;
property GDICanvas: TCanvas read GetGDICanvas;
property D2DCanvas: TDirect2DCanvas read FD2DCanvas;
published
{ The Paint event }
property Align;
property Anchors;
property DoubleBuffered;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Touch;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnGesture;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property OnStartDock;
property OnStartDrag;
property ParentBackground;
end;
procedure Register;
implementation
uses
System.SysUtils;
procedure Register;
begin
RegisterComponents('MyComponents', [TCustomAcceleratedPaintBox]);
end;
{ TCustomAcceleratedPaintBox }
constructor TCustomAcceleratedPaintBox.Create(AOwner: TComponent);
begin
inherited;
end;
function TCustomAcceleratedPaintBox.CreateD2DCanvas: Boolean;
begin
try
FD2DCanvas := TDirect2DCanvas.Create(Handle);
except
{ Failed creating the D2D canvas, halt! }
Exit(false);
end;
Result := true;
end;
procedure TCustomAcceleratedPaintBox.CreateWnd;
begin
inherited;
{ Try to create the custom canvas }
if (Win32MajorVersion >= 6) and (Win32Platform = VER_PLATFORM_WIN32_NT) then
FUseD2D := CreateD2DCanvas
else
FUseD2D := false;
end;
destructor TCustomAcceleratedPaintBox.Destroy;
begin
if FD2DCanvas <> nil then
FD2DCanvas.Free;
inherited;
end;
function TCustomAcceleratedPaintBox.GetGDICanvas: TCanvas;
begin
if FUseD2D then
Result := nil
else
Result := inherited Canvas;
end;
function TCustomAcceleratedPaintBox.GetOSCanvas: TCustomCanvas;
begin
if FUseD2D then
Result := FD2DCanvas
else
Result := inherited Canvas;
end;
procedure TCustomAcceleratedPaintBox.Paint;
begin
if FUseD2D then
begin
D2DCanvas.Font.Assign(Font);
D2DCanvas.Brush.Color := Color;
if csDesigning in ComponentState then
begin
D2DCanvas.Pen.Style := psDash;
D2DCanvas.Brush.Style := bsSolid;
D2DCanvas.Rectangle(0, 0, Width, Height);
end;
end else
begin
GDICanvas.Font.Assign(Font);
GDICanvas.Brush.Color := Color;
if csDesigning in ComponentState then
begin
GDICanvas.Pen.Style := psDash;
GDICanvas.Brush.Style := bsSolid;
GDICanvas.Rectangle(0, 0, Width, Height);
end;
end;
if Assigned(FOnPaint) then FOnPaint(Self);
end;
procedure TCustomAcceleratedPaintBox.SetAccelerated(const Value: Boolean);
begin
{ Same value? }
if Value = FUseD2D then
Exit;
if not Value then
begin
FUseD2D := false;
Repaint;
end else
begin
FUseD2D := FD2DCanvas <> nil;
if FUseD2D then
Repaint;
end;
end;
procedure TCustomAcceleratedPaintBox.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
begin
if FUseD2D then
begin
BeginPaint(Handle, PaintStruct);
try
FD2DCanvas.BeginDraw;
try
Paint;
finally
FD2DCanvas.EndDraw;
end;
finally
EndPaint(Handle, PaintStruct);
end;
end else
inherited;
end;
procedure TCustomAcceleratedPaintBox.WMSize(var Message: TWMSize);
begin
if FD2DCanvas <> nil then
begin
var NewSize := D2D1SizeU(Width, Height); <-- úprava proti orginálnímu kódu, ID2D1HwndRenderTarget.Resize chce var parametr
ID2D1HwndRenderTarget(FD2DCanvas.RenderTarget).Resize(NewSize);
end;
inherited;
end;
end.
[code=delphi]
