文档章节

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

涂孟超
 涂孟超
发布于 2014/09/26 15:35
字数 652
阅读 8
收藏 0
测试效果图:



自定义的 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

 
 
 
 
 

 

 

  

本文转载自:http://www.cnblogs.com/del/archive/2008/11/18/1335820.html

共有 人打赏支持
涂孟超
粉丝 12
博文 2011
码字总数 14107
作品 0
深圳
程序员
OpenGL超级宝典笔记——画三角形

学习了画线的知识,我们可以使用GLLINELOOP来画闭合的多边形。但是使用这种方式画出来的只有线框,多边形没有填充颜色。OpenGL支持绘制实心的多边形,并使用当前的颜色进行填充。 三角形 简单...

Mario_Q
2013/09/12
0
0
判断区域B是否在区域A内部的快速算法

在图像分析中,经常需要判断图像分割所得到的区域之间的关系。通常情况,我们通过八邻接外轮廓(准确说法是扩展边缘,但这样又得费半天口舌解释什么是扩展边缘)来描述一个区域并对区域进行标...

最美的回忆
2017/07/19
0
0
怎么用几何画板演示多边形滚动动画

如果我们生活中的车轮不是圆形的,而是正方形,那么我们应该修什么样的路,这样才能够使有正方形车轮的车辆如履平地?这是数学中的一个思维扩散题,其实不仅仅是正方形,还可以想象成是任意多...

学术研究软件
2016/11/17
29
0
OpenGL超级宝典笔记——其他图元

四边形 OpenGL的GLQUADS图元,可以指定4个点画出四边形。这些多边形具有顺时针环绕的方向。PS:四边形的四个角必须位于同一个平面 GLQUADSSTRIP图元可以画四边形带。 通用多边形 GLPOLYGONS...

Mario_Q
2013/09/15
0
0
计算几何之三角剖分--Art Gallery Problem

Art Gallery Problem 我们先引入一个著名的Art Gallery问题: 对于一个多边形的画廊,需要多少个摄像头(360度无死角)才能完全覆盖? 圆点为摄像头。其实就转化为了这样一个问题: 作为一名...

superPershing
2017/03/26
0
0

没有更多内容

加载失败,请刷新页面

加载更多

docker update:更新一个或多个容器的配置

更新容器的配置 docker update:更新一个或多个容器的配置。 具体内容请访问:https://docs.docker.com/engine/reference/commandline/update/#options 语法:docker update [OPTIONS] CONTA...

lwenhao
29分钟前
1
0
unload事件

unload事件不触发的原因分析 1.代码位置不对,应该优先加载,不能放到回调函数中 2.浏览器不支持 3.最可能的原因,unload事件中触发的函数是一个异步执行的函数,浏览器是不允许在窗口关闭之后在...

狮子狗
41分钟前
1
0
DbForge Schema Compare for MySQL入门教程:如何连接到数据库

【dbForge Schema Compare for MySQL下载】 要创建连接: 1. 在“Connection” 工具栏上单击“New Connection”按钮 。 2. 在“Host” 框中输入主机名。 3. 在“Port” 框中输入端口信息。默...

Miss_Hello_World
44分钟前
1
0
公众号关联微信小程序

公众号关联小程序发送关联通知,对于推广小程序有着很大的帮助。所以问题来了,怎么做到在公众号关联小程序发送关联通知呢? 一:开发中遇到的问题 之前在开发过程中发现,公众号已经关联小程...

Code辉
57分钟前
1
0
并发编程基础之JMM学习摘要

一、JMM定义 Java内存模型即Java Memory Model(JMM),JMM决定一个线程对共享变量的写入何时对另一个线程可见(内存可见性),从抽象的角度来看,JMM定义了线程和主内存之间的抽象关系:线程...

狠一点
今天
1
0

没有更多内容

加载失败,请刷新页面

加载更多

返回顶部
顶部