|
|
请大家看一下如下程序,在一幅图的多数地方选择都是正确的,我发现有一个多边形选不到其里面的物体(看付图):
Sub gHH()
Dim selobj As Object
ThisDrawing.Utility.GetEntity selobj, basePoint, "请选择线："
SelObjByPoly selobj
End Sub
Function SelObjByPoly(Ent As AcadEntity) As AcadSelectionSet
Dim Coord As Variant
Dim CoordCount As Integer
Dim NewCoord() As Double
Dim SelPoly As AcadSelectionSet
Dim minpnt As Variant '对象边框最小点坐标
Dim maxpnt As Variant '对象边框最大点坐标
Dim zminpnt(0 To 2) As Double '不闭合对象的缩放点左下角点坐标
Dim zmaxpnt(0 To 2) As Double '不闭合对象的缩放点右上角点坐标
ThisDrawing.Layers.Item("SXD").LayerOn = True
Ent.GetBoundingBox minpnt, maxpnt
zminpnt(0) = minpnt(0) ' - 800
zminpnt(1) = minpnt(1) '- 800
zminpnt(2) = 0
zmaxpnt(0) = maxpnt(0) '+ 800
zmaxpnt(1) = maxpnt(1) '+ 800
zmaxpnt(2) = 0
ThisDrawing.Application.ZoomWindow zminpnt, zmaxpnt
On Error GoTo Err1:
Set SelPoly = ThisDrawing.SelectionSets.Add("SelP")
If TypeName(Ent) = "IAcadLWPolyline" Then
Coord = Ent.Coordinates '获取顶点坐标数组
CoordCount = (UBound(Coord) + 1) / 2 '顶点数
'定义新的顶点坐标数组
ReDim NewCoord(0 To (3 * CoordCount - 1)) As Double
For j = 0 To UBound(Coord) - 1 Step 2
NewCoord((3 * j) / 2) = Coord(j)
NewCoord((3 * j) / 2 + 1) = Coord(j + 1)
NewCoord((3 * j) / 2 + 2) = 0
Next j
ElseIf TypeName(Ent) = "IAcadPolyline" Then
Coord = Ent.Coordinates
CoordCount = (UBound(Coord) + 1) / 3
ReDim NewCoord(0 To UBound(Coord)) As Double
For j = 0 To UBound(Coord) - 1
NewCoord(j) = Coord(j)
NewCoord(j) = Coord(j)
NewCoord(j) = Coord(j)
Next j
End If
SelPoly.SelectByPolygon acSelectionSetCrossingPolygon, NewCoord
A = SelPoly.Count '个数为0
Set SelObjByPoly = SelPoly
ZoomPrevious
Exit Function
Err1:
ThisDrawing.SelectionSets.Item("SelP").Delete
Resume
End Function
本帖以下内容被隐藏保护；需要你回复后，才能看到！ 游客，如果您要查看本帖隐藏内容请 回复 |
|
置顶卡
