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

测试效果图:

---

自定义的 MyShape 单元:

---

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