gzy 发表于 2004-4-27 20:10:00

检查了好多遍都没有问题，可运行就是不行！

程序的目的是将3D多段线的所有节点的Z坐标去掉，然后生成一2D多段线。思路应该没有问题，可老提示坐标越界。哪位帮我看看到底是怎么回事。   用下面这个图形做测试。Sub test3Dto2D()
'创建选择集
Dim selset As AcadSelectionSet
Dim cor3 As Variant
Dim n As Integer
Dim a As Integer
a = 0
Set selset = ThisDrawing.SelectionSets.Add("sset")
selset.Select acSelectionSetAll         '遍历选择集并将每一个对象镜相
Dim entry As AcadObject
Dim pl As AcadLWPolylineFor Each entry In selset
   If entry.EntityName = "AcDb3dPolyline" Then
               cor3 = entry.Coordinates
               n = (UBound(cor3) + 1) * 2 / 3
               Dim pt() As Double
               ReDim pt(0 To n - 1) As Double                     For i = 0 To (n - 2) Step 2
                               pt(i) = cor3(a)
                               pt(i + 1) = cor3(a + 1)
                               a = a + 3
                     Next i
                     
               Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
               entry.Delete
       End If
Next entryselset.Delete '避免下次重复End Sub

subtlation 发表于 2004-4-27 20:33:00

在 entry.Delete后面加上 a=0

gzy 发表于 2004-4-27 20:36:00

嘿嘿！多谢，我太粗心了！

雪山飞狐_lzh 发表于 2004-4-27 20:42:00

本帖最后由 作者 于 2004-4-28 10:00:25 编辑

Sub tn = (UBound(cor3) + 1) * 2 / 3
               Dim pt() As Double
               ReDim pt(0 To n - 1) As Double
                     For i = 0 To (n - 2) Step 2这里太乱了，改为sub test3Dto2D()
'创建选择集
Dim selset As AcadSelectionSet
Dim cor3 As Variant
Dim n As Integer
Set selset = ThisDrawing.SelectionSets.Add("sset")
selset.Select acSelectionSetAll         '遍历选择集并将每一个对象镜相
Dim entry As AcadObject
Dim pl As AcadLWPolylineFor Each entry In selset
   If entry.EntityName = "AcDb3dPolyline" Then
               cor3 = entry.Coordinates
               n = (UBound(cor3) + 1) / 3
               Dim pt() As Double
               ReDim pt(0 To n * 2 - 1) As Double                     For i = 0 To n - 1
                               pt(i * 2) = cor3(i * 3)
                               pt(i * 2 + 1) = cor3(i * 3 + 1)
                     Next i
                     
               Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
               entry.Delete
       End If
Next entryselset.Delete '避免下次重复End Sub
页: [1]
查看完整版本: 检查了好多遍都没有问题，可运行就是不行！