多边形选择集遇到的奇怪问题

CAD之路

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:新块1.rar 
下载次数:3  文件大小:15.38 KB 
下载权限: 不限 以上  [免费赚D豆]

利用多边形选择集选择位于多边形和穿过多边形的对象，结果发现总有几根数据，无论怎么样都选择不了，选不中的数据见附件图形中的白色线。运行环境：VBA+Autocad2008.后测试，c#同样存在该问题。麻烦各位大神分析一下原因和解决方法。图形数据见附件CAD文件。
代码如下：

[Actionscript3] 纯文本查看 复制代码

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

yangjian001

谢谢楼主分享

Lisphk

把所有的对象都显示到屏幕内

CAD之路

这个肯定哦，在选择集创建前，已经做了：ThisDrawing.Application.ZoomExtents  这个操作了！

CAD之路

就没有人遇到过吗？或者用我传的数据直接测试一下？

Lisphk

CAD之路 发表于 2019-5-1 22:05
就没有人遇到过吗？或者用我传的数据直接测试一下？

手工在CAD下面，能选择到吗？另外，点表别有重点
你打印下点表看看

CAD之路

这些肯定没有问题哦.都考虑过了