[原创]三点的外接圆内切圆和九点圆函数

highflybir

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

3. Option Explicit
4. Const Pi = 3.14159265358979
5. Public Sub drawCircle()
6.   Dim pt1, pt2, pt3, Mp1, Mp2, Mp3 As Variant
7.   Dim CirObj As AcadCircle
8.   Dim CIR1, CIR2 As Variant
9.   
10.   On Error Resume Next
11.   
12.   '数据输入
13.   pt1 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入圆的第一点:")
14.   pt2 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入圆的第二点:")
15.   pt3 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入圆的第三点:")
16.   '三边长的中点
17.   Mp1 = Midpt(pt2, pt3)
18.   Mp2 = Midpt(pt3, pt1)
19.   Mp3 = Midpt(pt1, pt2)
20.   '求得结果
21.   CIR1 = ThreePointCircle(pt1, pt2, pt3)
22.   CIR2 = ThreePointCircle(Mp1, Mp2, Mp3)
23.   '画圆
24.   Set CirObj = ThisDrawing.ModelSpace.AddCircle(CIR1(0), CIR1(1)) '画外接圆
25.   Set CirObj = ThisDrawing.ModelSpace.AddCircle(CIR1(2), CIR1(3)) '画内切圆
26.   Set CirObj = ThisDrawing.ModelSpace.AddCircle(CIR2(0), CIR2(1)) '画九点圆
27.   
28. End Sub
29. Function ThreePointCircle(ByVal ptA, ptB, ptC As Variant) As Variant
30.   Dim a, b, c, p, Rad1, Rad2 As Double
31.   Dim TanHalfA, AngleofA, xA, xB, xC, H_AA As Double
32.   Dim ptAM, ptAT, Cen1, Cen2 As Variant
33.   Dim HPi, Direct As Double
34.   Dim CircleList(0 To 4) As Variant
35.   HPi = Pi / 2
36.   
37.   '三边边长
38.   a = Distance(ptB, ptC)                                                           'A边边长
39.   b = Distance(ptC, ptA)                                                           'B边边长
40.   c = Distance(ptA, ptB)                                                            'C边边长
41.   '边X轴角
42.   xA = ThisDrawing.Utility.AngleFromXAxis(ptB, ptC)                 'A边X轴角
43.   xB = ThisDrawing.Utility.AngleFromXAxis(ptC, ptA)                 'B边X轴角
44.   xC = ThisDrawing.Utility.AngleFromXAxis(ptA, ptB)                 'C边X轴角
45.   
46.   '下面的判断必不可少,否则会出错
47.   Direct = Delta(ptA, ptB, ptC)
48.   If Direct < 0 Then
49.     HPi = -HPi
50.   End If
51.   
52.   '开始计算
53.   If Abs(Sin(xA - xB) * Sin(xB - xC) * Sin(xC - xA)) < 0.00000001 Then
54.     MsgBox "你输入的三点在同一条直线上!", vbOKOnly, "出错警告"
55.   Else
56.     p = (a + b + c) / 2                                                                   '半周长
57.     TanHalfA = Sqr((p - b) * (p - c) / (p * (p - a)))                         '半角A的正切值
58.     AngleofA = 2 * Atn(TanHalfA)                                                 '角A
59.     '外接圆
60.     ptAM = ThisDrawing.Utility.PolarPoint(ptB, xA, a / 2)               'A边中点
61.     H_AA = a * tan(HPi - AngleofA) / 2                                          'A边弦高
62.     Cen1 = ThisDrawing.Utility.PolarPoint(ptAM, xA + HPi, H_AA) '外接圆圆心
63.     Rad1 = Distance(ptA, Cen1)                                                   '外接圆半径
64.     '内切圆
65.     ptAT = ThisDrawing.Utility.PolarPoint(ptA, xC, p - a)               'C边内切点
66.     Rad2 = Sqr((p - a) * (p - b) * (p - c) / p)                                   '内切圆半径
67.     Cen2 = ThisDrawing.Utility.PolarPoint(ptAT, xC + HPi, Rad2)  '内切圆圆心
68.   End If
69.   
70.   CircleList(0) = Cen1
71.   CircleList(1) = Rad1
72.   CircleList(2) = Cen2
73.   CircleList(3) = Rad2
74.   
75.   ThreePointCircle = CircleList
76.   
77. End Function
78. '距离函数
79. Function Distance(pt1, pt2 As Variant) As Double
80.   Dim x, y, z As Double
81.   x = pt1(0) - pt2(0)
82.   y = pt1(1) - pt2(1)
83.   z = pt1(2) - pt2(2)
84.   Distance = Sqr(x ^ 2 + y ^ 2 + z ^ 2)
85. End Function
86. '三点形成的左右拐的判定
87. Function Delta(pt1, pt2, pt3 As Variant) As Double
88.   Dim dx1, dy1, dx2, dy2 As Double
89.   dx1 = pt2(0) - pt1(0)
90.   dy1 = pt2(1) - pt1(1)
91.   dx2 = pt3(0) - pt1(0)
92.   dy2 = pt3(1) - pt1(1)
93.   Delta = dx1 * dy2 - dx2 * dy1
94. End Function
95. '中点函数
96. Function Midpt(pt1, pt2 As Variant) As Variant
97.   Dim vv(0 To 2) As Double
98.   vv(0) = (pt1(0) + pt2(0)) / 2
99.   vv(1) = (pt1(1) + pt2(1)) / 2
100.   vv(2) = (pt1(2) + pt2(2)) / 2
101.   Midpt = vv
102. End Function

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