明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 494|回复: 4

vba select选择集问题

[复制链接]
发表于 2017-11-21 14:11 | 显示全部楼层 |阅读模式
acselectsetcrossing进行选择时,矩形边框范围有最小的限制范围吗,我在选择时,有的时候可以选择到对象,有时选择不到对象。
我用手工方法把选择矩形框画出来,确认了要选择的对象确实是穿过矩形框。但是为什么就是选择不上该对象?

发表于 2018-1-2 16:48 | 显示全部楼层
有显示窗口限制 选前先zoomall 或 ZoomWindow
回复 支持 1 反对 0

使用道具 举报

发表于 2017-11-21 15:23 | 显示全部楼层
是不是虚线?如果从虚线部分穿过去的会选不到。
 楼主| 发表于 2017-11-22 08:47 | 显示全部楼层

我把代码贴出来了,大家有时间帮我看看。
基本思路是,在图形上选择一点,以此点为基础,向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
 楼主| 发表于 2018-2-24 09:59 | 显示全部楼层
tianshan888 发表于 2018-1-2 16:48
有显示窗口限制 选前先zoomall 或 ZoomWindow

嗯,后来我发现这个问题了,谢谢
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2018-9-26 20:25 , Processed in 0.182421 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表