Is there a TShape control based on a TWinControl - delphi

Question

Is there an equivalent control to TShape which will act as a container? I.e. derived from a WinControl

Answer 1

Not in the native VCL, no. The closest would be a TPanel with a custom-painted background. Otherwise, you will have to write your own (or find a third-party one) that derives from TCustomControl or TWinControl directly.

Answer 2

unit WinShape_U;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls,
Winapi.Windows, Vcl.Graphics, Vcl.ExtCtrls, Winapi.Messages;
type
TWinShape = class(TWinControl)
private
{ Private declarations }
FPen: TPen;
FBrush: TBrush;
FShape: TShapeType;
FCanvas: TCanvas;
procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen);
procedure SetShape(Value: TShapeType);
protected
{ Protected declarations }
property Canvas: TCanvas read FCanvas;
procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); override;
procedure Paint;
procedure CreateParams(var Params: TCreateParams); override;
procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
procedure StyleChanged(Sender: TObject);
property Align;
property Anchors;
property Brush: TBrush read FBrush write SetBrush;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Constraints;
property ParentShowHint;
property Pen: TPen read FPen write SetPen;
property Shape: TShapeType read FShape write SetShape default stRectangle;
property ShowHint;
property Touch;
property Visible;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnGesture;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Additional', [TWinShape]);
end;
{ TShape }
procedure TWinShape.ChangeScale(M, D: Integer; isDpiChange: Boolean);
begin
FPen.Width := MulDiv(FPen.Width, M, D);
inherited;
end;
constructor TWinShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
ControlStyle := ControlStyle + [csReplicatable];
Width := 65;
Height := 65;
FPen := TPen.Create;
FPen.OnChange := StyleChanged;
FBrush := TBrush.Create;
FBrush.OnChange := StyleChanged;
end;
procedure TWinShape.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;
destructor TWinShape.Destroy;
begin
FPen.Free;
FBrush.Free;
FCanvas.Free;
inherited Destroy;
end;
procedure TWinShape.Paint;
var
X, Y, W, H, S: Integer;
begin
with Canvas do
begin
Pen := FPen;
Brush := FBrush;
X := Pen.Width div 2;
Y := X;
W := Width - Pen.Width + 1;
H := Height - Pen.Width + 1;
if Pen.Width = 0 then
begin
Dec(W);
Dec(H);
end;
if W < H then S := W else S := H;
if FShape in [stSquare, stRoundSquare, stCircle] then
begin
Inc(X, (W - S) div 2);
Inc(Y, (H - S) div 2);
W := S;
H := S;
end;
case FShape of
stRectangle, stSquare:
Rectangle(X, Y, X + W, Y + H);
stRoundRect, stRoundSquare:
RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);
stCircle, stEllipse:
Ellipse(X, Y, X + W, Y + H);
end;
end;
end;
procedure TWinShape.SetBrush(Value: TBrush);
begin
FBrush.Assign(Value);
end;
procedure TWinShape.SetPen(Value: TPen);
begin
FPen.Assign(Value);
end;
procedure TWinShape.SetShape(Value: TShapeType);
begin
if FShape <> Value then
begin
FShape := Value;
Invalidate;
end;
end;
procedure TWinShape.StyleChanged(Sender: TObject);
begin
Invalidate;
end;
procedure TWinShape.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
Msg.Result := 1;
end;
procedure TWinShape.WMPaint(var Message: TWMPaint);
begin
if not (csDestroying in ComponentState) then
begin
Canvas.Lock;
try
Paint;
finally
Canvas.Unlock;
end;
end;
end;
end.