一个可以显示多边形的 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