robbin840311 发表于 2009-2-8 13:59:00

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

<p>&nbsp;效果如<a href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=73592">http://bbs.mjtd.com/forum.php?mod=viewthread&tid=73592</a></p><p>将多段线内部的对象提取出来在新的地方重新生成。</p><p>请问使用VBA怎么开发？</p>

home 发表于 2009-2-13 22:48:00

<p>这段代码是选择封闭多选段内的实体，生成一个选择集。</p><p>Public Sub SelectByPoly(ByRef SSet As AcadSelectionSet, ByVal objPline As AcadLWPolyline, ByVal mode As AcSelect)<br/>&nbsp;&nbsp;&nbsp; If objPline.Closed = False Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; MsgBox "作为边界的多段线不闭合！"<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Sub<br/>&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; '将轻量多段线的坐标输入到点数组中<br/>&nbsp;&nbsp;&nbsp; Dim pointArrs() As Double<br/>&nbsp;&nbsp;&nbsp; ReDim pointArrs((UBound(objPline.Coordinates) + 1) * 3 / 2 - 1)<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; Dim i As Integer<br/>&nbsp;&nbsp;&nbsp; For i = 0 To ((UBound(objPline.Coordinates) + 1) / 2 - 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; pointArrs(3 * i) = objPline.Coordinates(2 * i)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; pointArrs(3 * i + 1) = objPline.Coordinates(2 * i + 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; pointArrs(3 * i + 2) = 0<br/>&nbsp;&nbsp;&nbsp; Next i<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; SSet.SelectByPolygon mode, pointArrs<br/>End Sub</p><p>然后可以拷贝选择集中对象。</p>

天龙八部 发表于 2009-2-14 10:40:00

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

nhy12345678 发表于 2009-2-14 22:48:00

<p>将上面的代码再加个实例：把上面的改成一个函数</p><p>Sub atemp()<br/>Dim ss As AcadSelectionSet<br/>Dim ent As AcadEntity<br/>Dim a As AcadLWPolyline<br/>Dim p As Variant<br/>Set ss = ThisDrawing.SelectionSets.Add("sss") '在屏幕上选择筒灯或对象<br/>ThisDrawing.Utility.GetEntity ent, p, "选择一个封闭的多段线"<br/>If ent.ObjectName = "AcDbPolyline" Then<br/>&nbsp;&nbsp; Set a = ent<br/>&nbsp;&nbsp; SelectByPoly ss, a, acSelectionSetWindowPolygon<br/>End If<br/>For Each ent In ss<br/>&nbsp;&nbsp;&nbsp; ent.color = acBlue '这个是测试，在这里加入你的代码<br/>Next<br/>ss.Delete<br/>End Sub<br/></p><p></p><p>Public Function SelectByPoly(ByRef SSet As AcadSelectionSet, ByVal objPline As AcadLWPolyline, ByVal mode As AcSelect)<br/>&nbsp;&nbsp;&nbsp; If objPline.closed = False Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; MsgBox "作为边界的多段线不闭合！"<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Function<br/>&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; '将轻量多段线的坐标输入到点数组中<br/>&nbsp;&nbsp;&nbsp; Dim pointArrs() As Double<br/>&nbsp;&nbsp;&nbsp; ReDim pointArrs((UBound(objPline.Coordinates) + 1) * 3 / 2 - 1)<br/>&nbsp;&nbsp;&nbsp; Dim i As Integer<br/>&nbsp;&nbsp;&nbsp; For i = 0 To ((UBound(objPline.Coordinates) + 1) / 2 - 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; pointArrs(3 * i) = objPline.Coordinates(2 * i)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; pointArrs(3 * i + 1) = objPline.Coordinates(2 * i + 1)<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; pointArrs(3 * i + 2) = 0<br/>&nbsp;&nbsp;&nbsp; Next i<br/>&nbsp;&nbsp;&nbsp; SSet.SelectByPolygon mode, pointArrs<br/>End Function</p>
页: [1]
查看完整版本: [求助]将多段线内部的对象提取出来