【求救】多边形选择集遇到的奇怪问题

giswater · 发表于 2019-4-30 13:01:00

利用多边形选择集选择位于多边形和穿过多边形的对象，结果发现总有几根数据，无论怎么样都选择不了。这几根数据特点：①位于多边形内，且一个点在多边形上；②竖直90度。但是同样特点的数据，有的又可以被选中。选不中的数据见附件图形中的白色线。运行环境：VBA+2008.麻烦各位大神分析一下原因和解决方法。图形数据见附件CAD文件。
代码如下：

copy


Sub SelPl()
      ' On Error Resume Next
     Dim objSelect As AcadEntity
    Dim basePnt As Variant
    Dim objAdd As AcadEntity
    Dim lw As AcadLWPolyline
    Dim sss As AcadSelectionSet
    Set sss = CreateSelectionSet("zz")
    ThisDrawing.Utility.GetEntity objSelect, basePnt, vbCrLf & "请选择多边形："
   
     
    Dim k1 As Integer
    Dim k As Integer
    Dim pointarrays() As Double
    Dim i As Integer
    
    
    Set lw = objSelect
     k = UBound(lw.Coordinates)
    k1 = (k + 1) * 1.5
    
    
        ReDim pointarrays(0 To k1 - 1)
    For i = 0 To k1 / 3 - 1 Step 1                  '把坐标赋值给数组
         pointarrays(i * 3) = lw.Coordinates(i * 2)
         pointarrays(i * 3 + 1) = lw.Coordinates(i * 2 + 1)
         pointarrays(i * 3 + 2) = 0
    Next
    
   
    ThisDrawing.Application.ZoomExtents
    sss.Clear
    sss.SelectByPolygon acSelectionSetCrossingPolygon, pointarrays
    
    For Each objAdd In sss
    
       objAdd.color = 30
    Next
End Sub
Private Function CreateSelectionSet(Optional SSetName As String) As AcadSelectionSet
    On Error Resume Next
    ThisDrawing.SelectionSets(SSetName).Delete
    Set CreateSelectionSet = ThisDrawing.SelectionSets.Add(SSetName)
End Function

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

zzyong00 · 发表于 2019-5-2 21:46:00

copy

    Dim i As Integer, j As Integer
    
    
    Set lw = objSelect
    k = UBound(lw.Coordinates)
    k1 = (k + 1) * 3 \ 2
    
    
    ReDim pointarrays(0 To k1 - 1)
    For i = 0 To k1 - 1 Step 3                   '把坐标赋值给数组
        pointarrays(i) = lw.Coordinates(j)
        pointarrays(i + 1) = lw.Coordinates(j + 1)
        pointarrays(i + 2) = 0
        j = j + 2
    Next