如何实现将pline线中的圆弧段处理成连续的pline，用vba来实现
用vba来实现，如何实现将pline线中的圆弧段处理成连续的pline，我试着将它拟合再将其打断，它变成两段pline线了，各位能否给出更好的解决方法。给小弟指点密津不胜感谢！我也有同样的问题，斑竹帮忙解决阿
以下是我画的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
帮你修改了一下，使用AppendVertex添加顶点
本帖最后由 efan2000 于 2003-5-21 22:06:48 编辑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
页:
[1]