程序如下: Sub selectPl() Dim ent As AcadEntity Dim SelObj As AcadEntity Dim NumSel As Integer Dim Coord As Variant Dim CoordCount As Integer Dim NewCoord() As Double Dim i As Integer Dim ssetObj As AcadSelectionSet On Error GoTo Err1: Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SSET2") On Error Resume Next Do ThisDrawing.Utility.GetEntity ent, pnt, "选择多段线:" If Err Then Exit Sub If TypeName(ent) Like "IAcad*Polyline" Then Exit Do Loop If TypeName(ent) = "IAcadLWPolyline" Then Coord = ent.Coordinates CoordCount = (UBound(Coord) + 1) / 2 '顶点数 '定义新的顶点坐标数组 ReDim NewCoord(0 To (3 * CoordCount - 1)) As Double For i = 0 To UBound(Coord) - 1 Step 2 NewCoord((3 * i) / 2) = Coord(i) NewCoord((3 * i) / 2 + 1) = Coord(i + 1) NewCoord((3 * i) / 2 + 2) = 0 Next i ElseIf TypeName(ent) = "IAcadPolyline" Then Coord = ent.Coordinates CoordCount = (UBound(Coord) + 1) / 3 ReDim NewCoord(0 To UBound(Coord)) As Double For i = 0 To UBound(Coord) - 1 NewCoord(i) = Coord(i) NewCoord(i) = Coord(i) NewCoord(i) = Coord(i) Next
End If ssetObj.SelectByPolygon acSelectionSetWindowPolygon, NewCoord ssetObj.Highlight True ssetObj.Update NumSel = ssetObj.Count Exit Sub Err1: ThisDrawing.SelectionSets.Item("TEST_SSET2").Delete Resume End Sub |