vba select选择集问题
acselectsetcrossing进行选择时，矩形边框范围有最小的限制范围吗，我在选择时，有的时候可以选择到对象，有时选择不到对象。我用手工方法把选择矩形框画出来，确认了要选择的对象确实是穿过矩形框。但是为什么就是选择不上该对象？
有显示窗口限制 选前先zoomall 或 ZoomWindow 是不是虚线？如果从虚线部分穿过去的会选不到。
我把代码贴出来了，大家有时间帮我看看。
基本思路是，在图形上选择一点，以此点为基础，向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
tianshan888 发表于 2018-1-2 16:48
有显示窗口限制 选前先zoomall 或 ZoomWindow
嗯，后来我发现这个问题了，谢谢
页:
[1]