关于VBA intersectwith函数如何判断是否有交点的问题

heaven陌上花开

Signature

VBA:

RetVal = object.IntersectWith(IntersectObject, ExtendOption)object

Type: All drawing objects (except PViewport and PolygonMesh), AttributeReference

The objects this method applies to.

IntersectObject

Access: Input-only

Type: Object

The object can be one of the supported drawing objects or an AttributeReference.

ExtendOption

Access: Input-only

Type: AcExtendOption enum

This option specifies if none, one or both, of the objects are to be extended in order to attempt an intersection.

• acExtendNone: Does not extend either object.
• acExtendThisEntity: Extends the base object.
• acExtendOtherEntity: Extends the object passed as an argument.
• acExtendBoth: Extends both objects.
  

Return Value (RetVal)

Type: Variant (array of doubles)

The array of points where one object intersects another object in the drawing.

==============================

以上是官方帮助文件给的内容，没有交点即无返回值。帮助文件还给了一个例子

heaven陌上花开

heaven陌上花开 发表于 2019-11-22 12:22
这段是官方给的代码，楼主亲测是存在bug的，不管是否有交点，vartype的返回值都为8179，而不是vbempty， ...

2. 
   
3. Private Sub DrawAltitude(ByRef Altitude() As Double)  'VB输出数组要通过ByRef 引用才行，不能直接输出
   
4.     ConnectAutoCAD
   
5.     '获取交点并写入数组中
   
6.     Dim CrossPoint As Variant
   
7.     Dim pickedobjs1 As AcadEntity
   
8.     Dim pickedobjs2 As AcadEntity
   
9.     Dim nLWS, nLS As Integer
   
10.     nLWS = CorrLineObj.Count: nLS = GuideLinesObj.Count  '选中的对象个数
    
11.     Dim cpnts() As Double        '交点数组
    
12. '    Dim Altitude() As Double     '高程数组
    
13.     ReDim cpnts(0 To nLWS - 1, 0 To nLS - 1, 2) As Double '定义一个三维动态数组用于存放交点坐标
    
14.     ReDim Altitude(0 To nLWS - 1, 0 To nLS - 1, 2) As Double
    
15.     Dim i As Integer
    
16.     Dim j As Integer
    
17.     Dim k As Integer
    
18.     Dim textobj As AcadText
    
19.     i = 0: j = 0: k = 0
    
20.     For Each pickedobjs1 In CorrLineObj
    
21.         Thisdrawing.Utility.Prompt vbCrLf & (i + 1) & "/" & CorrLineObj.Count
    
22.         pickedobjs1.Highlight (True) '高亮选中的实体
    
23.         pickedobjs1.Update
    
24.         j = 0
    
25.         For Each pickedobjs2 In GuideLinesObj
    
26.             pickedobjs1.Highlight (True)  '高亮选中的实体
    
27.             pickedobjs1.Update
    
28. 
    
29.             CrossPoint = pickedobjs1.IntersectWith(pickedobjs2, acExtendNone) '获取交点
    
30.             
    
31.             If VarType(CrossPoint) <> vbEmpty Then '执行计算
    
32.                 Thisdrawing.Utility.Prompt vbCrLf & CrossPoint(1)
    
33.                 Thisdrawing.Utility.Prompt vbCrLf & CrossPoint(0) & "," & CrossPoint(1) & "," & CrossPoint(2)
    
34.                 cpnts(i, j, 0) = CrossPoint(0)
    
35.                 cpnts(i, j, 1) = CrossPoint(1)
    
36.                 cpnts(i, j, 2) = CrossPoint(2) '交点数组
    
37.                 Altitude(i, j, 0) = CrossPoint(0)
    
38.                 Altitude(i, j, 1) = CrossPoint(1) - CDbl(HeightBaseP(1)) + HeightBaseVal
    
39.                 Altitude(i, j, 2) = CrossPoint(2) '高程数组
    
40.                 '写入高程信息
    
41.                 textInBasePoint(0) = CrossPoint(0)
    
42.                 textInBasePoint(2) = CrossPoint(2)
    
43.                 Set textobj = Thisdrawing.ModelSpace.AddText(CStr(Format(Altitude(i, j, 1), "0.00")), textInBasePoint, 1.5)
    
44.                 textobj.Rotate textInBasePoint, pi / 2  '旋转90°布置
    
45.             End If
    
46.                  j = j + 1
    
47.         Next pickedobjs2
    
48.        i = i + 1
    
49.     Next pickedobjs1
    
50.     Thisdrawing.Utility.Prompt vbCrLf & "任务已完成！"
    
51. End Sub

<br /> Private Sub DrawAltitude(ByRef Altitude() As Double)  'VB输出数组要通过ByRef 引用才行，不能直接输出<br />     ConnectAutoCAD<br />     '获取交点并写入数组中<br />     Dim CrossPoint As Variant<br />     Dim pickedobjs1 As AcadEntity<br />     Dim pickedobjs2 As AcadEntity<br />     Dim nLWS, nLS As Integer<br />     nLWS = CorrLineObj.Count: nLS = GuideLinesObj.Count  '选中的对象个数<br />     Dim cpnts() As Double        '交点数组<br /> '    Dim Altitude() As Double     '高程数组<br />     ReDim cpnts(0 To nLWS - 1, 0 To nLS - 1, 2) As Double '定义一个三维动态数组用于存放交点坐标<br />     ReDim Altitude(0 To nLWS - 1, 0 To nLS - 1, 2) As Double<br />     Dim i As Integer<br />     Dim j As Integer<br />     Dim k As Integer<br />     Dim textobj As AcadText<br />     i = 0: j = 0: k = 0<br />     For Each pickedobjs1 In CorrLineObj<br />         Thisdrawing.Utility.Prompt vbCrLf & (i + 1) & "/" & CorrLineObj.Count<br />         pickedobjs1.Highlight (True) '高亮选中的实体<br />         pickedobjs1.Update<br />         j = 0<br />         For Each pickedobjs2 In GuideLinesObj<br />             pickedobjs1.Highlight (True)  '高亮选中的实体<br />             pickedobjs1.Update<br /> <br />             CrossPoint = pickedobjs1.IntersectWith(pickedobjs2, acExtendNone) '获取交点<br />             <br />             If VarType(CrossPoint) <> vbEmpty Then '执行计算<br />                 Thisdrawing.Utility.Prompt vbCrLf & CrossPoint(1)<br />                 Thisdrawing.Utility.Prompt vbCrLf & CrossPoint(0) & "," & CrossPoint(1) & "," & CrossPoint(2)<br />                 cpnts(i, j, 0) = CrossPoint(0)<br />                 cpnts(i, j, 1) = CrossPoint(1)<br />                 cpnts(i, j, 2) = CrossPoint(2) '交点数组<br />                 Altitude(i, j, 0) = CrossPoint(0)<br />                 Altitude(i, j, 1) = CrossPoint(1) - CDbl(HeightBaseP(1)) + HeightBaseVal<br />                 Altitude(i, j, 2) = CrossPoint(2) '高程数组<br />                 '写入高程信息<br />                 textInBasePoint(0) = CrossPoint(0)<br />                 textInBasePoint(2) = CrossPoint(2)<br />                 Set textobj = Thisdrawing.ModelSpace.AddText(CStr(Format(Altitude(i, j, 1), "0.00")), textInBasePoint, 1.5)<br />                 textobj.Rotate textInBasePoint, pi / 2  '旋转90°布置<br />             End If<br />                  j = j + 1<br />         Next pickedobjs2<br />        i = i + 1<br />     Next pickedobjs1<br />     Thisdrawing.Utility.Prompt vbCrLf & "任务已完成！"<br /> End Sub

heaven陌上花开

2. Sub Example_IntersectWith()
   
3.     ' This example creates a line and circle and finds the points at
   
4.     ' which they intersect.
   
5.    
   
6.     ' Create the line
   
7.     Dim lineObj As AcadLine
   
8.     Dim startPt(0 To 2) As Double
   
9.     Dim endPt(0 To 2) As Double
   
10.     startPt(0) = 1: startPt(1) = 1: startPt(2) = 0
    
11.     endPt(0) = 5: endPt(1) = 5: endPt(2) = 0
    
12.     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
    
13.         
    
14.     ' Create the circle
    
15.     Dim circleObj As AcadCircle
    
16.     Dim centerPt(0 To 2) As Double
    
17.     Dim radius As Double
    
18.     centerPt(0) = 3: centerPt(1) = 3: centerPt(2) = 0
    
19.     radius = 1
    
20.     Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)
    
21.     ZoomAll
    
22.       
    
23.     ' Find the intersection points between the line and the circle
    
24.     Dim intPoints As Variant
    
25.     intPoints = lineObj.IntersectWith(circleObj, acExtendNone)
    
26.    
    
27.     ' Print all the intersection points
    
28.     Dim I As Integer, j As Integer, k As Integer
    
29.     Dim str As String
    
30.     If VarType(intPoints) <> vbEmpty Then
    
31.         For I = LBound(intPoints) To UBound(intPoints)
    
32.             str = "Intersection Point[" & k & "] is: " & intPoints(j) & "," & intPoints(j + 1) & "," & intPoints(j + 2)
    
33.             MsgBox str, , "IntersectWith Example"
    
34.             str = ""
    
35.             I = I + 2
    
36.             j = j + 3
    
37.             k = k + 1
    
38.         Next
    
39.     End If
    
40. End Sub

Sub Example_IntersectWith()<br />     ' This example creates a line and circle and finds the points at<br />     ' which they intersect.<br />     <br />     ' Create the line<br />     Dim lineObj As AcadLine<br />     Dim startPt(0 To 2) As Double<br />     Dim endPt(0 To 2) As Double<br />     startPt(0) = 1: startPt(1) = 1: startPt(2) = 0<br />     endPt(0) = 5: endPt(1) = 5: endPt(2) = 0<br />     Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)<br />         <br />     ' Create the circle<br />     Dim circleObj As AcadCircle<br />     Dim centerPt(0 To 2) As Double<br />     Dim radius As Double<br />     centerPt(0) = 3: centerPt(1) = 3: centerPt(2) = 0<br />     radius = 1<br />     Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)<br />     ZoomAll<br />       <br />     ' Find the intersection points between the line and the circle<br />     Dim intPoints As Variant<br />     intPoints = lineObj.IntersectWith(circleObj, acExtendNone)<br />     <br />     ' Print all the intersection points<br />     Dim I As Integer, j As Integer, k As Integer<br />     Dim str As String<br />     If VarType(intPoints) <> vbEmpty Then<br />         For I = LBound(intPoints) To UBound(intPoints)<br />             str = "Intersection Point[" & k & "] is: " & intPoints(j) & "," & intPoints(j + 1) & "," & intPoints(j + 2)<br />             MsgBox str, , "IntersectWith Example"<br />             str = ""<br />             I = I + 2<br />             j = j + 3<br />             k = k + 1<br />         Next<br />     End If<br /> End Sub

heaven陌上花开

heaven陌上花开 发表于 2019-11-22 14:31
调试了一上午，问题终于得到解决，用Ubound（）-Lbound（）判断交点元素的个数即可，有交点时个数是2，无交 ...

1.   IntPoint = pickedobjs1.IntersectWith(pickedobjs2, acExtendNone) '获取交点
   
2.   sizeIP = UBound(IntPoint) - LBound(IntPoint) '计算交点中元素的个数，有交点时是2，无交点时-1
   
3.   If CDbl(sizeIP) = 2 Then '执行计算
   
4.                         Thisdrawing.Utility.Prompt vbCrLf & "有交点！"
   
5. 
   
6.   Else
   
7.       Thisdrawing.Utility.Prompt vbCrLf & "无交点！"
   
8.   End If

复制代码

heaven陌上花开

heaven陌上花开 发表于 2019-11-22 12:20

这段是官方给的代码，楼主亲测是存在bug的，不管是否有交点，vartype的返回值都为8179，而不是vbempty，下面附上我自己写的代码，一直解决不了判断是否存在交点的问题，还请老铁们指点一下迷津！

heaven陌上花开

命令:
1/1
8197
1642.23981521255,1368.34718727462,0
8197
1622.23981521255,1369.00846134891,0
8197
1602.23981521255,1369.64624601929,0
8197
1582.23981521255,1370.2276116206,0
8197
1596.11481521253,1369.83037327556,0
8197
1616.11481521252,1369.20936376302,0
8197
1636.11481521252,1368.54970245987,0
任务已完成！*取消*

heaven陌上花开

heaven陌上花开 发表于 2019-11-22 12:29
命令:
1/1
8197

这个是有交点时的响应

heaven陌上花开

heaven陌上花开 发表于 2019-11-22 12:29
这个是有交点时的响应

命令:
1/1
8197
*无效*


这个是无交点时的响应，验证了不管有无交点，intersectwith函数返回值均为8197

heaven陌上花开

调试了一上午，问题终于得到解决，用Ubound（）-Lbound（）判断交点元素的个数即可，有交点时个数是2，无交点时算出来的值为-1，如果有更好的方法欢迎提出.

heaven陌上花开

heaven陌上花开 发表于 2019-11-22 14:35

方法比较笨，但搜索了大半天都没看到有人提出解决方案，这个方法目前是可行的，欢迎大家提出更好的解决方案