提取所有直线的交点坐标？

taqqug

请教一下大家，我在cad中用vb画了一系列直线，要提取所有直线的交点坐标，该怎么编程实现？

maoyangmy

我觉得可以先提取所有直线的两个端点，然后以每条线为基准循环测试，逐个记录交点，求交点可以采用几何算法

woaishuijia

1. 
   $ S, c8 p, Q7 ]7 I9 Y
2.     Dim SS As AcadSelectionSet '声明选择集变量
   ( r6 x& {1 ~; }  U* ?) K4 w
3.     Dim Ft(0) As Integer, Fd(0) As Variant '声明选择集过滤器数组变量
   ; v4 O1 u) Q* u2 T; o9 h. Z1 X
4.     Dim P() As Double '声明一个双精度型动态数组,用于保存所有交点坐标
   
5.     Dim V As Variant '声明一个变体型变量,用于提取两直线的交点
   
6.     Dim I As Long, J As Long '循环变量
   , k. L& b- W5 J7 [5 }
7.     Dim S As String '一个字符串,用于消息框
   
8.    
   
9.     On Error Resume Next
   ( D/ _8 ~+ D, O5 Z
10.     Set SS = ThisDrawing.SelectionSets.Add("SS" ) '新建选择集
    
11.     Ft(0) = 0 '定义过滤器,组码为0,检查对象类型
    ! Z: g* g6 [( }- l
12.     Fd(0) = "line" '对象类型为直线
    
13.     SS.Select acSelectionSetAll, , , Ft, Fd '选择所有直线
    4 Y. k; A- w6 L; D) l2 |: u# S
14.     If SS.Count >= 2 Then '检查被加入选择集的直线数量,只有数量大于或等于2时才能检查交点
    5 ?  }% @0 S) w) L: N: W
15.         For I = 0 To SS.Count - 2 '用嵌套循环方式检查某条直线与其它所有直线的交点
    8 Z' Q( r+ A& J1 ]
16.             For J = I + 1 To SS.Count - 1
    
17.                 V = SS.Item(I).IntersectWith(SS.Item(J), acExtendNone) '获得交点,用两条直线均不延伸的模式
    / e# i: H7 `: v' E3 u" V: F
18.                 If UBound(V) = 2 Then '检查是否有交点
    2 Y1 Q# I2 U. {1 a, Y
19.                     If UBound(P, 2) < 0 Then '重定义数组
    
20.                         ReDim P(2, 0)
    
21.                     Else
    0 v4 c, y* C6 D# s( L. |+ D9 Z
22.                         ReDim Preserve P(2, UBound(P, 2) + 1)
    2 N6 i& n* v$ F' `9 D% G9 ?
23.                     End If
    # I& J* ~  O8 X/ i) R/ m
24.                     P(0, UBound(P, 2)) = V(0) '把交点坐标存入动态数组
    
25.                     P(1, UBound(P, 2)) = V(1)
    & I! h" W( f6 R+ f2 f
26.                     P(2, UBound(P, 2)) = V(2)
    & R  u: J! C' E8 Y; u# |
27.                 End If
    
28.             Next
    ; @5 p4 e$ N3 H4 T; V
29.         Next
    + b; K6 J; ?; C0 y2 V" e# \
30.         If UBound(P, 2) < 0 Then
    0 Q8 G9 K6 _- G! Q
31.             MsgBox "没有交点", vbOKOnly, "AutoCAD"
    - q% p9 p8 c/ o) E9 g0 v
32.         Else
    8 _$ k  e2 H% i6 z2 Z) B% r' x
33.             S = "共有 " & UBound(P, 2) + 1 & " 个交点"
    
34.             For I = 0 To UBound(P, 2)
    / \, ?- ?/ E, `8 q1 ?- `2 p
35.                 S = S & vbCrLf & P(0, I) & "," & P(1, I) & "," & P(2, I)
    
36.             Next
      L. c0 ~" F( X5 `5 g: \
37.             MsgBox S, vbOKOnly, "AutoCAD"
    ; w2 w/ q( q! o, |; o; [$ @  f
38.         End If
    
39.     Else
    
40.         MsgBox "直线少于两条", vbOKOnly, "AutoCAD"
    
41.     End If
    
42.     SS.Delete '删除用过的选择集
    - }6 ]5 Z, n  l: D2 j; i

复制代码

taqqug

谢谢了,我去研究一下!

taqqug

写得非常详细,非常感激

koutx

谢谢版主，又学会了一种方法。