计算图斑面积时的岛

arden

我用SelectByPolygon方法进行选择时总是不能选到与边界相连的内部多边形(图形见付件),我在开发论坛问了一个月了也没人回答,希望这里能得到帮助,先谢谢

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

arden

刚才没把付件搞上

happy336

谢谢分享，不错