找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 3172|回复: 6

[飞鸟集] 三点的外接圆内切圆和九点圆函数

[复制链接]

已领礼包: 8121个

财富等级: 富甲天下

发表于 2013-5-8 09:45:32 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
本帖最后由 Highflybird 于 2013-5-8 09:48 编辑

三点的外接圆,内切圆,和九点圆如果用CAD的画圆命令来说很容易,但是对于那些不希望用命令的场合下,VB就需要编写一个函数了。
下面是我写的,初次学VBA,望各位多多指教

[pcode=vb,true]
Option Explicit
Const Pi = 3.14159265358979
Public Sub drawCircle()
  Dim pt1, pt2, pt3, Mp1, Mp2, Mp3 As Variant
  Dim CirObj As AcadCircle
  Dim CIR1, CIR2 As Variant

  On Error Resume Next

  '数据输入
  pt1 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入圆的第一点:")
  pt2 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入圆的第二点:")
  pt3 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入圆的第三点:")
  '三边长的中点
  Mp1 = Midpt(pt2, pt3)
  Mp2 = Midpt(pt3, pt1)
  Mp3 = Midpt(pt1, pt2)
  '求得结果
  CIR1 = ThreePointCircle(pt1, pt2, pt3)
  CIR2 = ThreePointCircle(Mp1, Mp2, Mp3)
  '画圆
  Set CirObj = ThisDrawing.ModelSpace.AddCircle(CIR1(0), CIR1(1)) '画外接圆
  Set CirObj = ThisDrawing.ModelSpace.AddCircle(CIR1(2), CIR1(3)) '画内切圆
  Set CirObj = ThisDrawing.ModelSpace.AddCircle(CIR2(0), CIR2(1)) '画九点圆

End Sub
Function ThreePointCircle(ByVal ptA, ptB, ptC As Variant) As Variant
  Dim a, b, c, p, Rad1, Rad2 As Double
  Dim TanHalfA, AngleofA, xA, xB, xC, H_AA As Double
  Dim ptAM, ptAT, Cen1, Cen2 As Variant
  Dim HPi, Direct As Double
  Dim CircleList(0 To 4) As Variant
  HPi = Pi / 2

  '三边边长
  a = Distance(ptB, ptC)                                                           'A边边长
  b = Distance(ptC, ptA)                                                           'B边边长
  c = Distance(ptA, ptB)                                                            'C边边长
  '边X轴角
  xA = ThisDrawing.Utility.AngleFromXAxis(ptB, ptC)                 'A边X轴角
  xB = ThisDrawing.Utility.AngleFromXAxis(ptC, ptA)                 'B边X轴角
  xC = ThisDrawing.Utility.AngleFromXAxis(ptA, ptB)                 'C边X轴角

  '下面的判断必不可少,否则会出错
  Direct = Delta(ptA, ptB, ptC)
  If Direct < 0 Then
    HPi = -HPi
  End If

  '开始计算
  If Abs(Sin(xA - xB) * Sin(xB - xC) * Sin(xC - xA)) < 0.00000001 Then
    MsgBox "你输入的三点在同一条直线上!", vbOKOnly, "出错警告"
  Else
    p = (a + b + c) / 2                                                                   '半周长
    TanHalfA = Sqr((p - b) * (p - c) / (p * (p - a)))                         '半角A的正切值
    AngleofA = 2 * Atn(TanHalfA)                                                 '角A
    '外接圆
    ptAM = ThisDrawing.Utility.PolarPoint(ptB, xA, a / 2)               'A边中点
    H_AA = a * tan(HPi - AngleofA) / 2                                          'A边弦高
    Cen1 = ThisDrawing.Utility.PolarPoint(ptAM, xA + HPi, H_AA) '外接圆圆心
    Rad1 = Distance(ptA, Cen1)                                                   '外接圆半径
    '内切圆
    ptAT = ThisDrawing.Utility.PolarPoint(ptA, xC, p - a)               'C边内切点
    Rad2 = Sqr((p - a) * (p - b) * (p - c) / p)                                   '内切圆半径
    Cen2 = ThisDrawing.Utility.PolarPoint(ptAT, xC + HPi, Rad2)  '内切圆圆心
  End If

  CircleList(0) = Cen1
  CircleList(1) = Rad1
  CircleList(2) = Cen2
  CircleList(3) = Rad2

  ThreePointCircle = CircleList

End Function
'距离函数
Function Distance(pt1, pt2 As Variant) As Double
  Dim x, y, z As Double
  x = pt1(0) - pt2(0)
  y = pt1(1) - pt2(1)
  z = pt1(2) - pt2(2)
  Distance = Sqr(x ^ 2 + y ^ 2 + z ^ 2)
End Function
'三点形成的左右拐的判定
Function Delta(pt1, pt2, pt3 As Variant) As Double
  Dim dx1, dy1, dx2, dy2 As Double
  dx1 = pt2(0) - pt1(0)
  dy1 = pt2(1) - pt1(1)
  dx2 = pt3(0) - pt1(0)
  dy2 = pt3(1) - pt1(1)
  Delta = dx1 * dy2 - dx2 * dy1
End Function
'中点函数
Function Midpt(pt1, pt2 As Variant) As Variant
  Dim vv(0 To 2) As Double
  vv(0) = (pt1(0) + pt2(0)) / 2
  vv(1) = (pt1(1) + pt2(1)) / 2
  vv(2) = (pt1(2) + pt2(2)) / 2
  Midpt = vv
End Function

[/pcode]


请点击此处下载

查看状态:需购买或无权限

您的用户组是:游客

文件名称:3ptcir.rar 
下载次数:5  文件大小:12.18 KB 
下载权限: 不限 以上  [免费赚D豆]


论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 1268个

财富等级: 财源广进

发表于 2013-5-8 16:58:15 | 显示全部楼层
赞一个/鼓掌
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3916个

财富等级: 富可敌国

发表于 2013-5-21 20:39:16 | 显示全部楼层
不错不错!ARX做得很好,怎么会想起学VBA呢?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-4 12:36:02 | 显示全部楼层
楼主您好,您的程序中,一开始是需要自己输入点的,或点选,或输入坐标,有没有办法实现直接通过代码获得已经存在的对象的特殊点,比如已经存在的直线的中点、端点,圆的圆心、象限点、矩形的角点,等等~

谢谢啦~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-13 09:04:53 | 显示全部楼层
如何使用?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 12个

财富等级: 恭喜发财

发表于 2015-6-10 21:47:31 | 显示全部楼层
不错不错 ,什么都会{:soso_e179:}
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-11-24 10:14 , Processed in 0.204424 second(s), 45 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表