[求助]将多段线内部的对象提取出来

robbin840311

 效果如http://bbs.mjtd.com/forum.php?mod=viewthread&tid=73592

将多段线内部的对象提取出来在新的地方重新生成。

请问使用VBA怎么开发？

home

这段代码是选择封闭多选段内的实体，生成一个选择集。

Public Sub SelectByPoly(ByRef SSet As AcadSelectionSet, ByVal objPline As AcadLWPolyline, ByVal mode As AcSelect)
    If objPline.Closed = False Then
        MsgBox "作为边界的多段线不闭合！"
        Exit Sub
    End If
   
    '将轻量多段线的坐标输入到点数组中
    Dim pointArrs() As Double
    ReDim pointArrs((UBound(objPline.Coordinates) + 1) * 3 / 2 - 1)
   
    Dim i As Integer
    For i = 0 To ((UBound(objPline.Coordinates) + 1) / 2 - 1)
        pointArrs(3 * i) = objPline.Coordinates(2 * i)
        pointArrs(3 * i + 1) = objPline.Coordinates(2 * i + 1)
        pointArrs(3 * i + 2) = 0
    Next i
   
    SSet.SelectByPolygon mode, pointArrs
End Sub

然后可以拷贝选择集中对象。

天龙八部

不错,把POLYLINE的点坐坐标数据都放入了数组中,再以数组中的信息生成POLYLINE

nhy12345678

将上面的代码再加个实例：把上面的改成一个函数

Sub atemp()
Dim ss As AcadSelectionSet
Dim ent As AcadEntity
Dim a As AcadLWPolyline
Dim p As Variant
Set ss = ThisDrawing.SelectionSets.Add("sss") '在屏幕上选择筒灯或对象
ThisDrawing.Utility.GetEntity ent, p, "选择一个封闭的多段线"
If ent.ObjectName = "AcDbPolyline" Then
   Set a = ent
   SelectByPoly ss, a, acSelectionSetWindowPolygon
End If
For Each ent In ss
    ent.color = acBlue '这个是测试，在这里加入你的代码
Next
ss.Delete
End Sub

Public Function SelectByPoly(ByRef SSet As AcadSelectionSet, ByVal objPline As AcadLWPolyline, ByVal mode As AcSelect)
    If objPline.closed = False Then
        MsgBox "作为边界的多段线不闭合！"
        Exit Function
    End If
    '将轻量多段线的坐标输入到点数组中
    Dim pointArrs() As Double
    ReDim pointArrs((UBound(objPline.Coordinates) + 1) * 3 / 2 - 1)
    Dim i As Integer
    For i = 0 To ((UBound(objPline.Coordinates) + 1) / 2 - 1)
        pointArrs(3 * i) = objPline.Coordinates(2 * i)
        pointArrs(3 * i + 1) = objPline.Coordinates(2 * i + 1)
        pointArrs(3 * i + 2) = 0
    Next i
    SSet.SelectByPolygon mode, pointArrs
End Function