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

gzy

程序的目的是将3D多段线的所有节点的Z坐标去掉，然后生成一2D多段线。思路应该没有问题，可老提示坐标越界。哪位帮我看看到底是怎么回事。   用下面这个图形做测试。

2. Sub test3Dto2D()
3. '创建选择集
4. Dim selset As AcadSelectionSet
5. Dim cor3 As Variant
6. Dim n As Integer
7. Dim a As Integer
8. a = 0
9. Set selset = ThisDrawing.SelectionSets.Add("sset")
10. selset.Select acSelectionSetAll         '遍历选择集并将每一个对象镜相
11. Dim entry As AcadObject
12. Dim pl As AcadLWPolylineFor Each entry In selset
13.      If entry.EntityName = "AcDb3dPolyline" Then
14.                cor3 = entry.Coordinates
15.                n = (UBound(cor3) + 1) * 2 / 3
16.                Dim pt() As Double
17.                ReDim pt(0 To n - 1) As Double                       For i = 0 To (n - 2) Step 2
18.                                pt(i) = cor3(a)
19.                                pt(i + 1) = cor3(a + 1)
20.                                a = a + 3
21.                        Next i
22.                        
23.                Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
24.                entry.Delete
25.        End If
26. Next entryselset.Delete '避免下次重复End Sub

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

在 entry.Delete后面加上 a=0

gzy

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

雪山飞狐_lzh

2. Sub tn = (UBound(cor3) + 1) * 2 / 3
3.                Dim pt() As Double
4.                ReDim pt(0 To n - 1) As Double
5.                        For i = 0 To (n - 2) Step 2

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