如何实现将pline线中的圆弧段处理成连续的pline，用vba来实现

giswang

用vba来实现，如何实现将pline线中的圆弧段处理成连续的pline，我试着将它拟合再将其打断，它变成两段pline线了，各位能否给出更好的解决方法。给小弟指点密津不胜感谢！

jovy

以下是我画的tulun 程序，用polyline命令画出外面轮廓线， 但是在定义成块的时候出现问题了。
Sub tulun()
Dim tulunobj As Acad3DSolid

Dim curves(0 To 3) As AcadEntity
Dim points(0 To 5) As Double
Dim points1(0 To 5) As Double
Dim x1 As Double
Dim x2 As Double
Dim y1 As Double
Dim y2 As Double
Dim n1 As Double
Dim n2 As Double
Dim m1 As Double
Dim m2 As Double

Dim centpoint(0 To 2) As Double
Dim radius As Double
Dim sangle As Double
Dim eangle As Double
Dim sangle1 As Double

'定义参数
x1 = 0
y1 = 0
n1 = 0
m1 = 0
centpoint(0) = 4
centpoint(1) = 0
centpoint(2) = 0
radius = 8
sangle = 3 * 3.1415926 / 2
eangle = 3.1415926 / 2
sangle1 = 0
Do While x1 < 4
x2 = x1 + 0.1
y2 = Sqr(16 * x2)
points(0) = x1: points(1) = y1: points(2) = 0
points(3) = x2: points(4) = y2: points(5) = 0
Set curves(0) = ThisDrawing.ModelSpace.AddPolyline(points)
x1 = x2
y1 = y2
Loop
Do While n1 < 4
n2 = n1 + 0.1
m2 = Sqr(16 * n2) * (-1)
points1(0) = n1: points1(1) = m1: points1(2) = 0
points1(3) = n2: points1(4) = m2: points1(5) = 0
Set curves(1) = ThisDrawing.ModelSpace.AddPolyline(points1)
n1 = n2
m1 = m2
Loop
Set curves(2) = ThisDrawing.ModelSpace.AddArc(centpoint, radius, sangle, sangle1)
Set curves(3) = ThisDrawing.ModelSpace.AddArc(centpoint, radius, sangle1, eangle)

Dim regionobj As AcadRegion
regionobj = ThisDrawing.ModelSpace.AddRegion(curves)
Dim height As Double
Dim langle As Double
height = 10
langle = 0
Set tulunobj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobj(0), height, langle)

End Sub

efan2000

Sub tulun()
Dim tulunobj As Acad3DSolid

Dim curves(0 To 3) As AcadEntity
Dim points(0 To 5) As Double
Dim points1(0 To 5) As Double
Dim x1 As Double
Dim x2 As Double
Dim y1 As Double
Dim y2 As Double
Dim n1 As Double
Dim n2 As Double
Dim m1 As Double
Dim m2 As Double

Dim centpoint(0 To 2) As Double
Dim radius As Double
Dim sangle As Double
Dim eangle As Double
Dim sangle1 As Double

'定义参数
x1 = 0
y1 = 0
n1 = 0
m1 = 0
centpoint(0) = 4
centpoint(1) = 0
centpoint(2) = 0
radius = 8
sangle = 3 * 3.1415926 / 2
eangle = 3.1415926 / 2
sangle1 = 0
Dim tPt(0 To 2) As Double '这里增加了一个三维的Double数组，用于存放顶点
Do While x1 < 4
x2 = x1 + 0.1
y2 = Sqr(16 * x2)
points(0) = x1: points(1) = y1: points(2) = 0
points(3) = x2: points(4) = y2: points(5) = 0
tPt(0) = points(3): tPt(1) = points(4): tPt(2) = points(5)
If curves(0) Is Nothing Then
    Set curves(0) = ThisDrawing.ModelSpace.AddPolyline(points)
Else
    curves(0).AppendVertex tPt '改用AppendVertex来对刚生成的多义线添加顶点，新增的顶点为多义线的最后一点
End If
x1 = x2
y1 = y2
Loop
Do While n1 < 4
n2 = n1 + 0.1
m2 = Sqr(16 * n2) * (-1)
points1(0) = n1: points1(1) = m1: points1(2) = 0
points1(3) = n2: points1(4) = m2: points1(5) = 0
tPt(0) = points1(3): tPt(1) = points1(4): tPt(2) = points1(5)
If curves(1) Is Nothing Then
    Set curves(1) = ThisDrawing.ModelSpace.AddPolyline(points1)
Else
    curves(1).AppendVertex tPt
End If
n1 = n2
m1 = m2
Loop
Set curves(2) = ThisDrawing.ModelSpace.AddArc(centpoint, radius, sangle, sangle1)
Set curves(3) = ThisDrawing.ModelSpace.AddArc(centpoint, radius, sangle1, eangle)
Dim regionobj As Variant '这里应该为Variant类型
regionobj = ThisDrawing.ModelSpace.AddRegion(curves)
Dim height As Double
Dim langle As Double
height = 10
langle = 0
Set tulunobj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobj(0), height, langle)

End Sub