zoukankan      html  css  js  c++  java
  • 一个可以显示多边形的 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
    
  • 相关阅读:
    HAProxy、Keepalived 在 Ocatvia 的应用实现与分析
    Octavia 的 HTTPS 与自建、签发 CA 证书
    Octavia 创建 loadbalancer 的实现与分析
    OpenStack Rally 质量评估与自动化测试利器
    自建 CA 中心并签发 CA 证书
    Failed building wheel for netifaces
    通过 vSphere WS API 获取 vCenter Datastore Provisioned Space 置备空间
    OpenStack Placement Project
    我们建了一个 Golang 硬核技术交流群(内含视频福利)
    没有图形界面的软件有什么用?
  • 原文地址:https://www.cnblogs.com/del/p/1335820.html
Copyright © 2011-2022 走看看