intersectWith函数存在Bug？

zfbj

具体内容请参加下面的贴子：
dispbbs.asp?boardID=14&ID=48355&page=1

下面是我写的一段测试代码：
Public Sub test()
    On Error GoTo LAST
   
    Dim sset As AcadSelectionSet
    Set sset = ThisDrawing.SelectionSets.Add("Exapmle")
    sset.SelectOnScreen
   
    If sset.Count = 2 Then
        Dim ent1 As AcadEntity, ent2 As AcadEntity
        Set ent1 = sset.Item(0)
        Set ent2 = sset.Item(1)
        Dim pt As Variant
        pt = ent1.IntersectWith(ent2, acExtendNone)
       
        If UBound(pt) < 0 Then
            MsgBox "无交点"
        Else
            MsgBox "有交点"
        End If
    End If
   
LAST:
    sset.Delete
End Sub

gzmkshjsh

请版主多多发上VBA知识！

ljpnb

试了一下确实有问题，我试了有3组有交点，一组无交点，怪了。

无痕

确实只能求2个交点。。。

可能是cad实数运算的误差导致，但是用region的时候，在很小的阈值内cad自动处理了（当作闭合）

zfbj

同意楼上的意见，已经准备用别的方案来实现。

bjjob1

请教版主，如何求面域和直线的交点？
运行代码时，老是提示：object requred！
Sub Ch4_CreateRegion()
' 定义数组以保存面域的边界。
Dim curves(0 To 0) As AcadCircle
' 创建形成面域边界的圆。
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 2
center(1) = 2
center(2) = 0
radius = 5#
Set curves(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
Dim regionObj As Variant  ' 创建面域
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)

Dim pnt(0 To 2) As Double, pnt2(0 To 2) As Double

pnt(0) = 0: pnt(1) = 0: pnt(2) = 0
pnt2(0) = 0: pnt2(1) = 50: pnt2(2) = 0
Dim line As AcadLine
Set line = ThisDrawing.ModelSpace.AddLine(pnt, pnt2)

Dim inter_pnt As Variant

inter_pnt = line.IntersectWith(regionObj, acExtendNone)
MsgBox inter_pnt(0)

ZoomAll
End Sub

crazylsp

交点最好用集合来做selectiom.item改成collection.item。

crazylsp

Dim regionObj As Variant  ' 创建面域

面域是变量？可能是acadobject或acadRegion。

Real_King

跟高程有关吧？elevation

Real_King

两条相交线的高程应相等？