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

giswater

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

2. Sub SelPl()
   
3.       ' On Error Resume Next
   
4.      Dim objSelect As AcadEntity
   
5.     Dim basePnt As Variant
   
6.     Dim objAdd As AcadEntity
   
7.     Dim lw As AcadLWPolyline
   
8.     Dim sss As AcadSelectionSet
   
9.     Set sss = CreateSelectionSet("zz")
   
10. 
    
11. 
    
12.     ThisDrawing.Utility.GetEntity objSelect, basePnt, vbCrLf & "请选择多边形："
    
13.    
    
14.      
    
15.     Dim k1 As Integer
    
16.     Dim k As Integer
    
17.     Dim pointarrays() As Double
    
18.     Dim i As Integer
    
19.    
    
20.    
    
21.     Set lw = objSelect
    
22.      k = UBound(lw.Coordinates)
    
23.     k1 = (k + 1) * 1.5
    
24.    
    
25.    
    
26.         ReDim pointarrays(0 To k1 - 1)
    
27.     For i = 0 To k1 / 3 - 1 Step 1                  '把坐标赋值给数组
    
28.          pointarrays(i * 3) = lw.Coordinates(i * 2)
    
29.          pointarrays(i * 3 + 1) = lw.Coordinates(i * 2 + 1)
    
30.          pointarrays(i * 3 + 2) = 0
    
31.     Next
    
32.    
    
33.    
    
34.     ThisDrawing.Application.ZoomExtents
    
35.     sss.Clear
    
36.     sss.SelectByPolygon acSelectionSetCrossingPolygon, pointarrays
    
37.    
    
38.     For Each objAdd In sss
    
39.    
    
40.        objAdd.color = 30
    
41.     Next
    
42. End Sub
    
43. 
    
44. Private Function CreateSelectionSet(Optional SSetName As String) As AcadSelectionSet
    
45.     On Error Resume Next
    
46.     ThisDrawing.SelectionSets(SSetName).Delete
    
47.     Set CreateSelectionSet = ThisDrawing.SelectionSets.Add(SSetName)
    
48. End Function

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

zzyong00

1.     Dim i As Integer, j As Integer
   
2.    
   
3.    
   
4.     Set lw = objSelect
   
5.     k = UBound(lw.Coordinates)
   
6.     k1 = (k + 1) * 3 \ 2
   
7.    
   
8.    
   
9.     ReDim pointarrays(0 To k1 - 1)
   
10.     For i = 0 To k1 - 1 Step 3                   '把坐标赋值给数组
    
11.         pointarrays(i) = lw.Coordinates(j)
    
12.         pointarrays(i + 1) = lw.Coordinates(j + 1)
    
13.         pointarrays(i + 2) = 0
    
14.         j = j + 2
    
15.     Next
    
16.    
    
17.    

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

稍改改

giswater

mikewolf2k 发表于 2019-5-5 10:57
先试试看，感觉有时候这个crossing不大准，保险起见，两个方向各来一次。

试过了，多边形顺时针与逆时针选择对象效果一样，因此执行两次还是存在漏选情况，邪门了！！cad2008下vba与C#选择效果一样，换CAD2010一样存在漏选，但是居然漏选的对象不一样，奇葩CAD！！！

giswater

zzyong00 发表于 2019-5-2 21:46
稍改改

您可以用您的多边形点表与我的方法点表做比较，一模一样哦（本身算法就是一样，无非您多个变量而已，您可以仔细读读代码）。为了确定，我同样用您的方式，做过测试，实现效果也是一模一样。mikewolf2k 应该也试过，不然不会找其他问题了

giswater

你的这个没有必要修改啊，与我的效果一模一样，二维坐标转三维坐标。所以用你的替换，实现效果肯定与我的一模一样，也是部分线怎么都选不中，而且我用C#，实现效果一样；怀疑是CAD选择集本身的BUG。再求高手现身指导，谢谢!

woaishuijia

把多边形顶点顺序改为逆时针试试

giswater

woaishuijia 发表于 2019-5-4 06:10
把多边形顶点顺序改为逆时针试试

一样无效。确实成了无解了，怎么@原来的几个版主啊？

mikewolf2k

giswater 发表于 2019-5-5 08:29
一样无效。确实成了无解了，怎么@原来的几个版主啊？

先顺时针选一次，再逆时针选一次。（其实本质上需要的是逆时针的那次，但不知道多边形的的绘图顺序是顺时针还是逆时针，所以两种顺序都选一次，肯定又一次是真正的逆时针。）

giswater

mikewolf2k 发表于 2019-5-5 10:35
先顺时针选一次，再逆时针选一次。（其实本质上需要的是逆时针的那次，但不知道多边形的的绘图顺序是顺时 ...

这个什么原因或原理呢，如果这样可以解决，是不是以后所有的多边形选择都需要这样操作？十分感谢，我马上试试看可以不？

mikewolf2k

giswater 发表于 2019-5-5 10:48
这个什么原因或原理呢，如果这样可以解决，是不是以后所有的多边形选择都需要这样操作？十分感谢，我马上 ...

先试试看，感觉有时候这个crossing不大准，保险起见，两个方向各来一次。

mikewolf2k

好像的确是有bug，有时候能全选中，跟做不做zoomextents有时候也有关系。
试试用两点连线选择，不要用多边形选。