Autor Téma: TCustomAcceleratedPaintBox podle Embarcadera  (Přečteno 90 krát)

Offline Morrison

  • Hrdina
  • ****
  • Příspěvků: 385
  • Karma: 12
    • Verze Delphi: D5, XE2, 10.4.2, D11
TCustomAcceleratedPaintBox podle Embarcadera
« kdy: 30-11-2022, 10:41:41 »
Zkoušeli jste někdo ten TCustomAcceleratedPaintBox podle návodu https://docwiki.embarcadero.com/RADStudio/Sydney/en/Using_the_Direct2D_Canvas?
Mám s tím zase můj oblíbený problém, že pozadí není průhledné jako u standardního PaintBoxu. Například když kreslím elipsu, nebo prostě cokoliv, co nezabírá celou plochu.
Zkusil jsem jako předka dát TCustomTransparentControl, ale tím jsem dosáhl jen toho, že se nevykreslí vůbec nic a celé pozadí je černé.

Kód: Delphi [Vybrat]
  1. unit MyAcceleratedPaintBox;
  2.  
  3. interface
  4.  
  5. uses
  6.   System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Direct2D, D2D1, Winapi.Windows,
  7.   Winapi.Messages, Vcl.ExtCtrls;
  8.  
  9. type
  10.   TCustomAcceleratedPaintBox = class(TCustomControl)
  11.   private
  12.     FOnPaint: TNotifyEvent;
  13.     FUseD2D: Boolean;
  14.     FD2DCanvas: TDirect2DCanvas;
  15.  
  16.     function CreateD2DCanvas: Boolean;
  17.  
  18.     { Catching paint events }
  19.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  20.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  21.  
  22.     { Set/Get stuff }
  23.     procedure SetAccelerated(const Value: Boolean);
  24.     function GetGDICanvas: TCanvas;
  25.     function GetOSCanvas: TCustomCanvas;
  26.   protected
  27.     procedure CreateWnd; override;
  28.     procedure Paint; override;
  29.   public
  30.     { Life-time management }
  31.     constructor Create(AOwner: TComponent); override;
  32.     destructor Destroy(); override;
  33.  
  34.     { Public properties }
  35.     property Accelerated: Boolean read FUseD2D write SetAccelerated;
  36.     property Canvas: TCustomCanvas read GetOSCanvas;
  37.     property GDICanvas: TCanvas read GetGDICanvas;
  38.     property D2DCanvas: TDirect2DCanvas read FD2DCanvas;
  39.   published
  40.     { The Paint event }
  41.     property Align;
  42.     property Anchors;
  43.     property DoubleBuffered;
  44.     property Color;
  45.     property Constraints;
  46.     property DragCursor;
  47.     property DragKind;
  48.     property DragMode;
  49.     property Enabled;
  50.     property Font;
  51.     property ParentColor;
  52.     property ParentFont;
  53.     property ParentShowHint;
  54.     property PopupMenu;
  55.     property ShowHint;
  56.     property Touch;
  57.     property Visible;
  58.     property OnClick;
  59.     property OnContextPopup;
  60.     property OnDblClick;
  61.     property OnDragDrop;
  62.     property OnDragOver;
  63.     property OnEndDock;
  64.     property OnEndDrag;
  65.     property OnGesture;
  66.     property OnMouseActivate;
  67.     property OnMouseDown;
  68.     property OnMouseEnter;
  69.     property OnMouseLeave;
  70.     property OnMouseMove;
  71.     property OnMouseUp;
  72.     property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  73.     property OnStartDock;
  74.     property OnStartDrag;
  75.     property ParentBackground;
  76.   end;
  77.  
  78.   procedure Register;
  79.  
  80. implementation
  81.  
  82. uses
  83.   System.SysUtils;
  84.  
  85. procedure Register;
  86. begin
  87.   RegisterComponents('MyComponents', [TCustomAcceleratedPaintBox]);
  88. end;
  89.  
  90. { TCustomAcceleratedPaintBox }
  91.  
  92. constructor TCustomAcceleratedPaintBox.Create(AOwner: TComponent);
  93. begin
  94.   inherited;
  95. end;
  96.  
  97. function TCustomAcceleratedPaintBox.CreateD2DCanvas: Boolean;
  98. begin
  99.   try
  100.      FD2DCanvas := TDirect2DCanvas.Create(Handle);
  101.    except
  102.      { Failed creating the D2D canvas, halt! }
  103.      Exit(false);
  104.    end;
  105.  
  106.    Result := true;
  107. end;
  108.  
  109. procedure TCustomAcceleratedPaintBox.CreateWnd;
  110. begin
  111.   inherited;
  112.  
  113.    { Try to create the custom canvas }
  114.    if (Win32MajorVersion >= 6) and (Win32Platform = VER_PLATFORM_WIN32_NT) then
  115.      FUseD2D := CreateD2DCanvas
  116.    else
  117.      FUseD2D := false;
  118. end;
  119.  
  120. destructor TCustomAcceleratedPaintBox.Destroy;
  121. begin
  122.   if FD2DCanvas <> nil then
  123.     FD2DCanvas.Free;
  124.   inherited;
  125. end;
  126.  
  127. function TCustomAcceleratedPaintBox.GetGDICanvas: TCanvas;
  128. begin
  129.   if FUseD2D then
  130.      Result := nil
  131.    else
  132.      Result := inherited Canvas;
  133. end;
  134.  
  135. function TCustomAcceleratedPaintBox.GetOSCanvas: TCustomCanvas;
  136. begin
  137.   if FUseD2D then
  138.      Result := FD2DCanvas
  139.    else
  140.      Result := inherited Canvas;
  141. end;
  142.  
  143. procedure TCustomAcceleratedPaintBox.Paint;
  144. begin
  145.   if FUseD2D then
  146.    begin
  147.      D2DCanvas.Font.Assign(Font);
  148.      D2DCanvas.Brush.Color := Color;
  149.  
  150.      if csDesigning in ComponentState then
  151.      begin
  152.        D2DCanvas.Pen.Style := psDash;
  153.        D2DCanvas.Brush.Style := bsSolid;
  154.  
  155.        D2DCanvas.Rectangle(0, 0, Width, Height);
  156.      end;
  157.    end else
  158.    begin
  159.      GDICanvas.Font.Assign(Font);
  160.      GDICanvas.Brush.Color := Color;
  161.  
  162.      if csDesigning in ComponentState then
  163.      begin
  164.        GDICanvas.Pen.Style := psDash;
  165.        GDICanvas.Brush.Style := bsSolid;
  166.  
  167.        GDICanvas.Rectangle(0, 0, Width, Height);
  168.      end;
  169.    end;
  170.  
  171.    if Assigned(FOnPaint) then FOnPaint(Self);
  172. end;
  173.  
  174. procedure TCustomAcceleratedPaintBox.SetAccelerated(const Value: Boolean);
  175. begin
  176.   { Same value? }
  177.    if Value = FUseD2D then
  178.      Exit;
  179.  
  180.    if not Value then
  181.    begin
  182.      FUseD2D := false;
  183.      Repaint;
  184.    end else
  185.    begin
  186.      FUseD2D := FD2DCanvas <> nil;
  187.  
  188.      if FUseD2D then
  189.        Repaint;
  190.    end;
  191. end;
  192.  
  193. procedure TCustomAcceleratedPaintBox.WMPaint(var Message: TWMPaint);
  194. var
  195.   PaintStruct: TPaintStruct;
  196. begin
  197.   if FUseD2D then
  198.   begin
  199.     BeginPaint(Handle, PaintStruct);
  200.     try
  201.       FD2DCanvas.BeginDraw;
  202.       try
  203.         Paint;
  204.       finally
  205.         FD2DCanvas.EndDraw;
  206.       end;
  207.  
  208.     finally
  209.       EndPaint(Handle, PaintStruct);
  210.     end;
  211.   end else
  212.     inherited;
  213. end;
  214.  
  215. procedure TCustomAcceleratedPaintBox.WMSize(var Message: TWMSize);
  216. begin
  217.   if FD2DCanvas <> nil then
  218.   begin
  219.     var NewSize := D2D1SizeU(Width, Height); <-- úprava proti orginálnímu kódu, ID2D1HwndRenderTarget.Resize chce var parametr
  220.     ID2D1HwndRenderTarget(FD2DCanvas.RenderTarget).Resize(NewSize);
  221.   end;
  222.  
  223.   inherited;
  224. end;
  225.  
  226. end.
  227. [code=delphi]
nil