一个可以显示多边形的 TMyShape 类 - 回复 "董勇" 的问题

unit MyShape;

interface

uses
Windows, Classes, Graphics, Controls;

type
TMyShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,
stEllipse, stCircle, stPolygon);

TPoints = array of TPoint;

TMyShape = class(TGraphicControl) {根据 TShape 改写}
private
FPen: TPen;
FBrush: TBrush;
FShape: TMyShapeType;
FPonits: TPoints;
procedure SetBrush(Value: TBrush);
procedure SetPen(Value: TPen);
procedure SetShape(Value: TMyShapeType);
procedure SetPonits(const Value: TPoints);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
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: TMyShapeType read FShape write SetShape default stRectangle;
property ShowHint;
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 OnStartDock;
property OnStartDrag;
property Ponits: TPoints read FPonits write SetPonits;
end;

implementation

{ MyTShape }

constructor TMyShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
Width := 65;
Height := 65;
FPen := TPen.Create;
FPen.OnChange := StyleChanged;
FBrush := TBrush.Create;
FBrush.OnChange := StyleChanged;
end;

destructor TMyShape.Destroy;
begin
FPen.Free;
FBrush.Free;
inherited Destroy;
end;

procedure TMyShape.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);
stPolygon:
Polygon(FPonits);
end;
end;
end;

procedure TMyShape.StyleChanged(Sender: TObject);
begin
Invalidate;
end;

procedure TMyShape.SetBrush(Value: TBrush);
begin
FBrush.Assign(Value);
end;

procedure TMyShape.SetPen(Value: TPen);
begin
FPen.Assign(Value);
end;

procedure TMyShape.SetShape(Value: TMyShapeType);
begin
if FShape <> Value then
begin
FShape := Value;
Invalidate;
end;
end;

procedure TMyShape.SetPonits(const Value: TPoints);
var
i,x,y: Integer;
begin
FPonits := Value;
for i := 0 to Length(Value) - 1 do
begin
x := Value[i].X;
y := value[i].Y;
if Left > x then Left := x;
if Top > y then Top := y;
if Width < x then Width := x;
if Height < y then Height := y;
end;
Invalidate;
end;

end.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

uses MyShape;

var
shape: TMyShape;

procedure TForm1.Button1Click(Sender: TObject);
var
pts: TPoints;
i: Integer;
begin
Randomize;
SetLength(pts, Random(4)+3); {随机测试: 最少是三角形、最多是七边形}
for i := 0 to Length(pts) - 1 do
begin
pts[i].X := Random(ClientWidth);
pts[i].Y := Random(ClientHeight);
end;
shape.Ponits := pts;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
pts: TPoints;
begin
shape := TMyShape.Create(Self);

SetLength(pts, 4);
pts[0] := Point(ClientWidth div 2, 10);
pts[1] := Point(ClientWidth - 10, ClientHeight div 2);
pts[2] := Point(ClientWidth div 2, ClientHeight - 10);
pts[3] := Point(10, ClientHeight div 2);

shape.Ponits := pts;
shape.Shape := stPolygon;
shape.Parent := Self;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
shape.Free;
end;

end.

object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 206
ClientWidth = 339
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 256
Top = 160
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end