vba select选择集问题

hawk00754

acselectsetcrossing进行选择时，矩形边框范围有最小的限制范围吗，我在选择时，有的时候可以选择到对象，有时选择不到对象。
我用手工方法把选择矩形框画出来，确认了要选择的对象确实是穿过矩形框。但是为什么就是选择不上该对象？

tianshan888

有显示窗口限制 选前先zoomall 或 ZoomWindow

mikewolf2k

是不是虚线？如果从虚线部分穿过去的会选不到。

hawk00754

我把代码贴出来了，大家有时间帮我看看。
基本思路是，在图形上选择一点，以此点为基础，向X正方向搜索，搜索到对象后，以此点为基础向搜索到的对象做一条垂线，同时返回垂足，然后在垂足为基础，继续搜索，直到循环结束。
现在问题是，通过acselectsetcrossing搜索不到对象，两次循环的矩形边框都是有重叠的，从理论上说，是连续搜索，不存在因为增量步长大，而边框小，造成两次循环所扫过的区间有间隙。
Function splitline_compound()
    Dim px, nx, transPnt As Variant
    Dim vobj As Variant
    Dim num As Integer
    px = ThisDrawing.Utility.GetPoint(, "select a point: ")
    nx = px
    ZoomExtents
    'x正方向搜索
    num = 20 '循环次数
     Do While num > 0
        Set vobj = searchobj(px, 1, 0#)
        'MsgBox TypeName(vobj)
        If vobj Is Nothing Then
            Exit Do
        End If
        transPnt = normalline(px, vobj)'画垂线，没有贴上来
        px = transPnt
        num = num - 1
     Loop
End Function
'搜索对象
Function searchobj(returnPnt As Variant, Optional dx As Double = 1, Optional dy As Double = -1) As AcadEntity
    Dim sset As AcadSelectionSet
    Dim count As Integer
    count = ThisDrawing.SelectionSets.count
    While count > 0
        count = count - 1
        Set sset = ThisDrawing.SelectionSets.item(count)
        sset.Delete
    Wend
    Set sset = ThisDrawing.SelectionSets.Add("TEST")
'Dim returnPnt As Variant
'returnPnt = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
    Dim cc As Variant
    Dim st(0 To 2) As Double
    Dim inc As Double   '增量步长
    Dim length As Double    '搜索范围
    st(0) = returnPnt(0)   'X坐标
    st(1) = returnPnt(1)   'Y坐标
    st(2) = returnPnt(2)   'Z坐标
    inc = 0.1'每次增加0.1mm
    length = 30
    Do While length > 0
        st(0) = st(0) + dx * inc
        st(1) = st(1) + dy * inc
        cc = recscale(st, 0.1)’矩形框计算，这里得到0.2*0.2的正方形边框
        sset.Select acSelectionSetCrossing, cc(0), cc(1)
        If sset.count = 1 Then
            Exit Do
        End If
        length = length - inc
        sset.Clear
    Loop
'ThisDrawing.ModelSpace.AddPoint (st)
    If sset.count = 1 Then
        Set searchobj = sset.item(0)
    Else
        Set searchobj = Nothing
    End If
    sset.Delete
End Function
'矩形框的大小
Function recscale(cnt As Variant, Optional fs As Double = 0.05) As Variant
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
    Dim r As Double
    r = 1#
    corner1(0) = cnt(0) + fs * r
    corner1(1) = cnt(1) + fs * r
    corner1(2) = 0#
    ''
    corner2(0) = cnt(0) - fs * r
    corner2(1) = cnt(1) - fs * r
    corner2(2) = 0#
    recscale = Array(corner1, corner2)
End Function

hawk00754

tianshan888 发表于 2018-1-2 16:48
有显示窗口限制 选前先zoomall 或 ZoomWindow

嗯，后来我发现这个问题了，谢谢