|
|
发表于 2006-1-5 14:57:00
|
显示全部楼层
程序如下:
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
|
|
置顶卡
请点击此处下载
