[转帖]VBA-三点划弧

兰州人

研究一下这个帖子，将三点划弧做成模板。
http://www.cnblogs.com/raymond19840709/archive/2007/04/12/710393.html

2. Private Function GetCenOf3Pt(pt1 As Variant, pt2 As Variant, pt3 As Variant, ByRef radius As Double) As Variant
3. ''''根据三点计算出圆心和半径
4. Dim xysm, xyse, xy As Double
5. Dim ptCen(2) As Double
6. xy = pt1(0) ^ 2 + pt1(1) ^ 2
7. xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2
8. xysm = xy - pt2(0) ^ 2 - pt2(1) ^ 2
9. xy = (pt1(0) - pt2(0)) * (pt1(1) - pt3(1)) - (pt1(0) - pt3(0)) * (pt1(1) - pt2(1))
10. '''判断参数有效性
11. If Abs(xy) < 0.000001 Then
12. MsgBox "所输入的参数无法创建圆形！"
13. Exit Function
14. End If
15. '获得圆心和半径
16. ptCen(0) = (xysm * (pt1(1) - pt3(1)) - xyse * (pt1(1) - pt2(1))) / (2 * xy)
17. ptCen(1) = (xyse * (pt1(0) - pt2(0)) - xysm * (pt1(0) - pt3(0))) / (2 * xy)
18. ptCen(2) = 0
19. radius = Sqr((pt1(0) - ptCen(0)) * (pt1(0) - ptCen(0)) + (pt1(1) - ptCen(1)) * (pt1(1) - ptCen(1)))
20. If radius < 0.000001 Then
21. MsgBox "半径过小！"
22. Exit Function
23. End If
24. ''函数返回圆心的位置，而半径则在参数中通过引用方式返回
25. GetCenOf3Pt = ptCen
26. End Function
28. Public Function AddArc3Pt(ByVal ptSt As Variant, ByVal ptSc As Variant, ByVal ptEn As Variant) As AcadArc
29. ''''三点法创建圆弧
30. Dim objArc As AcadArc
31. Dim ptCen As Variant
32. Dim radius As Double
33. ptCen = GetCenOf3Pt(ptSt, ptSc, ptEn, radius)
34. If isClockWise(ptCen, ptSt, ptSc, ptEn) Then
35. Set objArc = AddArcCSEP(ptCen, ptSt, ptEn)
36. Else
37. Set objArc = AddArcCSEP(ptCen, ptEn, ptSt)
38. End If
39. objArc.Update
40. Set AddArc3Pt = objArc
41. End Function
43. Private Function AddArcCSEP(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant) As AcadArc
44. Dim objArc As AcadArc
45. Dim radius As Double
46. Dim stAng, enAng As Double
47. ''计算半径
48. radius = 100 'GetDistance(ptCen, ptSt)
49. ''计算起点角度和终点角度
50. stAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
51. enAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn)
52. Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
53. objArc.Update
54. Set AddArcCSEP = objArc
55. End Function
56. '判断三点的方向
57. Function isClockWise(ptCen, ptSt, ptSc, ptEn) As Boolean
58. a1 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
59. a2 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSc)
60. a3 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn)
61. isClockWise = (a1 < a2) Xor (a2 < a3) Xor (a1 < a3)
62. End Function
63. Sub ls()
64.   Dim aa As AcadArc
65.   Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, pppp(0 To 2) As Double
66.   pp(0) = 0: pp(1) = 10: pp(2) = 0
67.   ppp(0) = 10: ppp(1) = 100: ppp(2) = 0
68.   pppp(0) = -20: pppp(1) = -110: pppp(2) = 0
69.   Set aa = AddArcCSEP(pp, ppp, pppp)
70.   
71. End Sub

Private Function GetCenOf3Pt(pt1 As Variant, pt2 As Variant, pt3 As Variant, ByRef radius As Double) As Variant ''''根据三点计算出圆心和半径 Dim xysm, xyse, xy As Double Dim ptCen(2) As Double xy = pt1(0) ^ 2 + pt1(1) ^ 2 xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2 xysm = xy - pt2(0) ^ 2 - pt2(1) ^ 2 xy = (pt1(0) - pt2(0)) * (pt1(1) - pt3(1)) - (pt1(0) - pt3(0)) * (pt1(1) - pt2(1)) '''判断参数有效性 If Abs(xy) < 0.000001 Then MsgBox "所输入的参数无法创建圆形！" Exit Function End If '获得圆心和半径 ptCen(0) = (xysm * (pt1(1) - pt3(1)) - xyse * (pt1(1) - pt2(1))) / (2 * xy) ptCen(1) = (xyse * (pt1(0) - pt2(0)) - xysm * (pt1(0) - pt3(0))) / (2 * xy) ptCen(2) = 0 radius = Sqr((pt1(0) - ptCen(0)) * (pt1(0) - ptCen(0)) + (pt1(1) - ptCen(1)) * (pt1(1) - ptCen(1))) If radius < 0.000001 Then MsgBox "半径过小！" Exit Function End If ''函数返回圆心的位置，而半径则在参数中通过引用方式返回 GetCenOf3Pt = ptCen End Function Public Function AddArc3Pt(ByVal ptSt As Variant, ByVal ptSc As Variant, ByVal ptEn As Variant) As AcadArc ''''三点法创建圆弧 Dim objArc As AcadArc Dim ptCen As Variant Dim radius As Double ptCen = GetCenOf3Pt(ptSt, ptSc, ptEn, radius) If isClockWise(ptCen, ptSt, ptSc, ptEn) Then Set objArc = AddArcCSEP(ptCen, ptSt, ptEn) Else Set objArc = AddArcCSEP(ptCen, ptEn, ptSt) End If objArc.Update Set AddArc3Pt = objArc End Function Private Function AddArcCSEP(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant) As AcadArc Dim objArc As AcadArc Dim radius As Double Dim stAng, enAng As Double ''计算半径 radius = 100 'GetDistance(ptCen, ptSt) ''计算起点角度和终点角度 stAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt) enAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn) Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng) objArc.Update Set AddArcCSEP = objArc End Function '判断三点的方向 Function isClockWise(ptCen, ptSt, ptSc, ptEn) As Boolean a1 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt) a2 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSc) a3 = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn) isClockWise = (a1 < a2) Xor (a2 < a3) Xor (a1 < a3) End Function Sub ls()   Dim aa As AcadArc   Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, pppp(0 To 2) As Double   pp(0) = 0: pp(1) = 10: pp(2) = 0   ppp(0) = 10: ppp(1) = 100: ppp(2) = 0   pppp(0) = -20: pppp(1) = -110: pppp(2) = 0   Set aa = AddArcCSEP(pp, ppp, pppp)    End Sub