AutoCAD VBA创建圆弧

AutoCAD VBA创建圆弧，已经圆心、起点和终点；圆心、起点和角度；三点法；圆心、起点和弧长等。代码如下。

‘模块中代码

Public Function AddArcCSEA(ByVal ptCen As Variant, ByVal radius As Double, ByVal stAng As Double, ByVal enAng As Double) As AcadArc
On errro GoTo errHandle
Dim objArc As AcadArc
Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
objArc.color = acBlue
objArc.Update
Set AddArcCSEA = objArc
Exit Function
errHandle:
MsgBox Err.Description
End Function
Public 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 = 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.color = acCyan
objArc.Update
Set AddArcCSEP = objArc
End Function
Public Function GetDistance(sp As Variant, ep As Variant) As Double
Dim x As Double
Dim y As Double
Dim z As Double
x = sp(0) - ep(0)
y = sp(1) - ep(1)
z = sp(2) - ep(2)
GetDistance = Sqr((x ^ 2) + (y ^ 2) + (z ^ 2))
End Function
Public Function AddArcCSPA(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal angle As Double) As AcadArc
Dim objArc As AcadArc
Dim ptEn As Variant
Dim angTemp As Double
Dim radius As Double
angTemp = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
angTemp = angTemp + angle
radius = GetDistance(ptCen, ptSt)
ptEn = ThisDrawing.Utility.PolarPoint(ptCen, angTemp, radius)
Set objArc = AddArcCSEP(ptCen, ptSt, ptEn)
objArc.color = acRed
objArc.Update
Set AddArcCSPA = objArc
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)
Set objArc = AddArcCSEP(ptCen, ptSt, ptEn)
objArc.color = acGreen
objArc.Update
Set AddArc3Pt = objArc
End Function
Public 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 AddArcCSPL(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal length As Double) As AcadArc
Dim objArc As AcadArc
Dim radius As Double
Dim angle As Double
radius = GetDistance(ptCen, ptSt)
angle = length / radius
Set objArc = AddArcCSPA(ptCen, ptSt, angle)
objArc.color = acMagenta
objArc.Update
Set AddArcCSPL = objArc
End Function

‘ThisDrawing中代码

Public Sub TestArc()
Dim ptCen(2) As Double
ptCen(0) = 100: ptCen(1) = 100: ptCen(2) = 0
Dim objArc1 As AcadArc
Set objArc1 = AddArcCSEA(ptCen, 50, 0.8, 2.3)
ptCen(0) = 100: ptCen(1) = 90: ptCen(2) = 0
Dim objArc2 As AcadArc
Set objArc2 = AddArcCSEP(ptCen, objArc1.StartPoint, objArc1.EndPoint)
Dim objarc3 As AcadArc
Set objarc3 = AddArcCSPA(ptCen, objArc1.EndPoint, 2)
Dim pt1(2) As Double
pt1(0) = 140: pt1(1) = 60: pt1(2) = 0
Dim objArc4 As AcadArc
Set objArc4 = AddArc3Pt(objarc3.EndPoint, pt1, objArc2.StartPoint)
Dim pt2(2) As Double
pt2(0) = 70: pt2(1) = 100: pt2(2) = 0
Dim objArc5 As AcadArc
Set objArc5 = AddArcCSPL(ptCen, pt2, 30)
ZoomAll
End Sub

代码完。

和示例上的效果不一样。