[求助]选择集选取语法没错，为什么会漏选图元呢？求助高手！！
检查了好几遍，没发现出问题，但是求不出所有的交点，是选择集出了问题，没有选取所以符合条件的图元。至于为什么没有选到，就不知道了，求助高手啊。
语法应该没有问题
Private Sub CommandButton1_Click()
On Error Resume Next
UserForm1.Hide
'选择等高线
Dim EntObj(0 To 0) As AcadEntity
Dim PPt As Variant
ThisDrawing.Utility.GetEntity EntObj(0), PPt, "选择等高线: "
If EntObj(0) Is Nothing Then Exit Sub
'求直线的外框
Dim Pt1 As Variant
Dim Pt2 As Variant
EntObj(0).GetBoundingBox Pt1, Pt2
'创建选择集
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets("SSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
ssetObj.Clear
'只选取图层为DGX的图层
'选择与该直线相交或者包含在外框中的所有实体
Dim fType(0) As Integer
Dim fData(0) As Variant
fType(0) = 8: fData(0) = "dgx"
ssetObj.Select acSelectionSetCrossing, Pt1, Pt2, fType, fData
'由于其中包含了自身实体，故应从选择集中移走
'由于移去函数的参数是对象集合，所以在上面定义的是单个对象的对象集合
ssetObj.RemoveItems EntObj
Dim entTempElev As Double
entTempElev = EntObj(0).Elevation
EntObj(0).Elevation = 0
'将等高线高程暂时化为0，原高程存储到数组elevTemp（）中
Dim I As Integer
Dim elevTemp() As Double
ReDim elevTemp(1 To ssetObj.Count)
For I = 1 To ssetObj.Count
elevTemp(I) = ssetObj.Item(I).Elevation
ssetObj.Item(I).Elevation = 0
ssetObj.Item(I).Update
Next
'枚举交点，判断是否相交
Dim pts As Variant
Dim circle1() As AcadCircle
ReDim circle1(ssetObj.Count - 1)
Dim a As Integer
For I = 0 To ssetObj.Count - 1
pts = ssetObj(I).IntersectWith(EntObj(0), acExtendNone)
If Not IsEmpty(pts) Then
Dim circleT(2) As Double
circleT(0) = pts(0): circleT(1) = pts(1): circleT(2) = 0
circle1(I) = ThisDrawing.ModelSpace.AddCircle(circleT, 0.5)
End If
Next
EntObj(0).Elevation = entTempElev
For I = 1 To ssetObj.Count
ssetObj.Item(I).Elevation = elevTemp(I)
ssetObj.Item(I).Update
Next
UserForm1.Show
End Sub
**** Hidden Message ***** 我选择黑线,然后求得了交点:
没发现什么问题!
你用那根等高线试试，就是我贴图上的那根与另外好几根差不多同样属性的多段线试试
我试验的时候，结果想贴图的那样，应该有6个交点的，但实际只画了5个圆，只返回5个交点
以下红色为错误,已更改，再试试，呵呵，粗心了点
Option Explicit
Private Sub CommandButton1_Click()
On Error Resume Next
UserForm1.Hide
'选择等高线
Dim EntObj(0 To 0) As AcadEntity
Dim PPt As Variant
ThisDrawing.Utility.GetEntity EntObj(0), PPt, "选择等高线: "
If EntObj(0) Is Nothing Then Exit Sub
'求直线的外框
Dim Pt1 As Variant
Dim Pt2 As Variant
EntObj(0).GetBoundingBox Pt1, Pt2
'创建选择集
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets("SSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
ssetObj.Clear
'只选取图层为DGX的图层
'选择与该直线相交或者包含在外框中的所有实体
Dim fType(0) As Integer
Dim fData(0) As Variant
fType(0) = 8: fData(0) = "dgx"
ssetObj.Select acSelectionSetCrossing, Pt1, Pt2, fType, fData
'由于其中包含了自身实体，故应从选择集中移走
'由于移去函数的参数是对象集合，所以在上面定义的是单个对象的对象集合
ssetObj.RemoveItems EntObj
Dim entTempElev As Double
entTempElev = EntObj(0).Elevation
EntObj(0).Elevation = 0
'将等高线高程暂时化为0，原高程存储到数组elevTemp（）中
Dim I As Integer
Dim elevTemp() As Double
ReDim elevTemp(0 To ssetObj.Count - 1)'这里错误，范围应为0~count-1
For I = 0 To ssetObj.Count - 1'这里错误，范围应为0~count-1
elevTemp(I) = ssetObj.Item(I).Elevation
ssetObj.Item(I).Elevation = 0
ssetObj.Item(I).Update
Next
'枚举交点，判断是否相交
Dim pts As Variant
Dim circle1() As AcadCircle
ReDim circle1(ssetObj.Count - 1)
Dim a As Integer
For I = 0 To ssetObj.Count - 1
pts = ssetObj(I).IntersectWith(EntObj(0), acExtendNone)
If Not IsEmpty(pts) Then
Dim circleT(2) As Double
circleT(0) = pts(0): circleT(1) = pts(1): circleT(2) = 0
circle1(I) = ThisDrawing.ModelSpace.AddCircle(circleT, 0.5)
End If
Next
EntObj(0).Elevation = entTempElev
For I = 0 To ssetObj.Count - 1)'这里错误，范围应为0~count-1
ssetObj.Item(I).Elevation = elevTemp(I)
ssetObj.Item(I).Update
Next
UserForm1.Show
End Sub
学习了 谢谢！ 真的可以了，太谢谢了，困扰了一天
页:
[1]