[求助]关于选择集，当图纸缩小或者扩大超出可视范围时的影响

bluefires

请教一个问题，我写了一个程序，是为了判断我的图纸里面有没有2个以上的块叠在一起，或者说如果是2个块叠加在一起就一定要一个是“上穿孔”，一个是“下穿孔”，要不是的话就标志出来。如果我把这个图纸放大到全部显示的情况下程序没有问题，可如果当我把图纸缩小的非常下的时候（可以吧图纸缩小到一个点那么大），就会发现所有的块都被标志了，我查看了程序，竟然发现所有的块都被我用ssetObj2.Select mode, corner1, corner2, filterType, filterData所构成的块选择中了。当然如果扩大超出可视范围则有问题的块也不能被发现了（这个我还能解释）。问下大家这个问题该怎么解决，如果仅仅从选择集没有办法解决的华，还有其他思路吗。图纸和代码都在压缩包里面。

bluefires

我看了论坛上这个帖子，也是相同的问题

http://www.mjtd.com/BBS/dispbbs.asp?BoardID=4&replyID=29150&id=36383&skin=0

特别是这段话，我觉得和我体会以一样：（hangc兄 ， 在实践中 发现选择集确实和范围有关。


我现在使用acSelectionSetWindow之前都要先 zoom一下。）

bluefires

或许有的人要问，你干嘛把图纸缩小的那么小啊，放大点不久可以了，可事实是我要处理的图纸太大了，不是一般的大，所以实际上的节点就是非常小的。恳请大家帮我提供一条思路，怎么解决这个问题。

fjfhgdwfn

在循环中用选择集应是不好的，楼主可以考虑用插入点的距离进行判断不？

不过这样速度比较慢啊

Private Sub CommandButton1_Click()
    Dim retCoord As Variant
    Dim elem As AcadEntity
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
    Dim dd, rr As Double
    rr = 23.5651 * 2
    Dim ptMin, ptMax
    Dim objRec As AcadLWPolyline
    '关于扩展数据的变量
    Dim dataType(0 To 1) As Integer
    Dim data(0 To 1) As Variant
    dataType(0) = 1001: data(0) = "MY_NodeSign"
    dataType(1) = 1000: data(1) = "blkMark"

    '创建选择集，用于选择设备
    Dim ssetObj1 As AcadSelectionSet
    Dim filterType(0 To 6) As Integer
    Dim filterData(0 To 6) As Variant
    '安全的建立选择集
    Set ssetObj1 = CreateSelectionSet("SSET1")

    Dim mode As Integer
    '创建两个选择集，用于选择设备
    Dim ssetObj2 As AcadSelectionSet
    '选择模式为通过某个区域
    mode = acSelectionSetCrossing
    '安全的建立选择集
   
   
    '防止出现ESC错误
    'On Error Resume Next

    filterType(0) = 0
    filterData(0) = "Insert"
    filterType(1) = 100
    filterData(1) = "AcDbBlockReference"
    filterType(2) = -4
    filterData(2) = "<or"
    filterType(3) = 2
    filterData(3) = "上穿孔"
    filterType(4) = 2
    filterData(4) = "下穿孔"
    filterType(5) = 2
    filterData(5) = "节点"
    filterType(6) = -4
    filterData(6) = "or>"
    ssetObj1.Select acSelectionSetAll, , , filterType, filterData
 MsgBox ssetObj1.Count

    '创建图块列表、扫描模型空间集合
    For Each elem In ssetObj1
        retCoord = elem.InsertionPoint
        '建立一个以首尾某个点为中心的长和宽为20MM的矩形
        corner1(0) = retCoord(0)
        corner1(1) = retCoord(1)
        corner1(2) = 0
       
        For Each elem2 In ssetObj1
        If elem.Handle = elem2.Handle Then GoTo nextelem2
       
        retCoord = elem2.InsertionPoint
        corner2(0) = retCoord(0)
        corner2(1) = retCoord(1)
        corner2(2) = 0
       
        dd = ((corner1(0) - corner2(0)) ^ 2 + (corner1(1) - corner2(1)) ^ 2) ^ 0.5

        If dd - rr < 0.001 Then
            If (elem.Name = "上穿孔" And elem2.Name = "下穿孔") Or _
            (elem2.Name = "上穿孔" And elem.Name = "下穿孔") Then
     
            Else '当有2个块叠在一起，别且不是 "上穿孔"和 "下穿孔"对应的情况下，则标志之
                elem.GetBoundingBox ptMin, ptMax
                Set objRec = AddSignRectangle(ptMin, ptMax, 1)
                objRec.color = acRed '151
                objRec.SetXData dataType, data
                objRec.Update
            End If
        End If
nextelem2:
    Next elem2
    Next elem
   
   
    ssetObj1.Delete
End Sub

bluefires

呵呵，阁下这个思路确实不错，真是谢谢了，我觉得你这个思路的速度应该也还可以，我今天采用了ZoomWindow point1，point2 这个命令解决了这个问题，感觉速度还可以。