Question

关于用VBA在CAD中求交点的问题(急)

我写了一个宏，求任意选择的线段的交点，并在交点上画圆。如果每两条线都相交，那么不会出错，如果有一条线段和另一条线段不相交，就会出错，怎么办？？？？
代码如下：
Dim docA As AcadDocument
Dim SLST As AcadSelectionSet
Dim pp As Variant, pp1 As Variant
Dim ppt(0 To 2) As Double
Dim a As AcadEntity, TPV As AcadEntity, TPV2 As AcadEntity
Dim IPCOL As New Collection
Dim SIPCOL As New Collection
Dim i As Double, j As Double
Set docA = Application.ActiveDocument
docA.Activate

For Each SLST In docA.SelectionSets
If SLST.Name = "qhh" Then
SLST.Delete
Exit For
End If
Next
Set SLST = docA.SelectionSets.Add("qhh")
SLST.SelectOnScreen
For Each a In SLST

IPCOL.Add a

Next
num = IPCOL.Count
MsgBox num

For i = 1 To IPCOL.Count - 1
Set TPV = IPCOL(i)
For j = i + 1 To IPCOL.Count
Set TPV2 = IPCOL(j)
pp = TPV.IntersectWith(TPV2, 2)

SIPCOL.Add pp

Next j
Next i
num = SIPCOL.Count
MsgBox num
For i = 1 To SIPCOL.Count
With docA.ModelSpace.AddCircle(SIPCOL(i), 2)
End With
Next i
如果能帮我改过来,达到满意效果的话，我再加100分。有兴趣和我讨论的可以Q我，我QQ：278836166

Answer 1

把这句
SIPCOL.Add pp
改为:
If UBound(pp) = 2 Then SIPCOL.Add pp
根据你的意图，是要的是直线的交点，直线的交点只有一个点，下标应为2
若改成If UBound(pp) >= 2 Then SIPCOL.Add pp 依旧不完善
因为当你已经画了交点圆之后，再度执行代码的时候，圆与直线有两个交点，所以UBound(pp)=5
执行到 With docA.ModelSpace.AddCircle(SIPCOL(i), 20) 会报错，因为SIPCOL(i)不再是一个点的坐标了。

Answer 2

具体实现代码如下：

Sub IntersectWith333() '''''求直线和直线及直线和圆弧的交点坐标
Dim point1, point2, point3, point4, p As Variant
Dim entLine1 As AcadLine, entLine2 As AcadLine, entLine3 As AcadLine
'输入四个点
point1 = ThisDrawing.Utility.GetPoint(, "输入第一个顶点：")
'point1(0) = 12: point1(1) = 13: point1(2) = 0
point2 = ThisDrawing.Utility.GetPoint(, "输入第二个顶点：")
'point2(0) = 13: point2(1) = 7: point2(2) = 0
point3 = ThisDrawing.Utility.GetPoint(, "输入第三个顶点：")
'point3(0) = 19: point3(1) = 12: point3(2) = 0
point4 = ThisDrawing.Utility.GetPoint(, "输入第四个顶点：")
'point3(0) = 8: point3(1) = 17: point3(2) = 0
'根据四个点画三条线
Set entLine1 = ThisDrawing.ModelSpace.AddLine(point1, point2)
Set entLine2 = ThisDrawing.ModelSpace.AddLine(point2, point3)
Set entLine3 = ThisDrawing.ModelSpace.AddLine(point3, point4)
'求直线和直线的交点坐标 及直线和圆弧
Dim intPoints As Variant
intPoints = entLine1.IntersectWith(entLine3, acExtendBoth)

MsgBox "直线1和直线3的交点：交点1坐标为" & intPoints(0) & " " & intPoints(1) & " " & intPoints(2)
'''则直线1和直线3的交点：交点1坐标为 '11.6065573770492 , 15.3606557377049 , 0

Answer 3

把这句
SIPCOL.Add pp
改为:
If UBound(pp) >= 2 Then SIPCOL.Add pp
就OK了.
没交点时，pp返回空值，当然会出错了！