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

taqqug

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

maoyangmy

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

woaishuijia

1. 
   . H. L- v$ _7 g0 {9 P
2.     Dim SS As AcadSelectionSet '声明选择集变量
   - M- x/ ]8 ^% T3 F$ F
3.     Dim Ft(0) As Integer, Fd(0) As Variant '声明选择集过滤器数组变量
   . J3 x, ?) H4 O) q' T6 d
4.     Dim P() As Double '声明一个双精度型动态数组,用于保存所有交点坐标
   0 @' ~3 p. l( r3 I0 \( ?/ c. S
5.     Dim V As Variant '声明一个变体型变量,用于提取两直线的交点
   
6.     Dim I As Long, J As Long '循环变量
   4 z$ B) I* _2 S* P, w: K
7.     Dim S As String '一个字符串,用于消息框
   $ J- r& b! U' |9 M5 c
8.    
   . S; S* V6 T3 F+ m$ x7 `
9.     On Error Resume Next
   
10.     Set SS = ThisDrawing.SelectionSets.Add("SS" ) '新建选择集
    
11.     Ft(0) = 0 '定义过滤器,组码为0,检查对象类型
    " e) W3 T/ V: s2 b1 Y- O* Q
12.     Fd(0) = "line" '对象类型为直线
    ( [& t: E) S# j. \5 d3 M; I$ w0 I
13.     SS.Select acSelectionSetAll, , , Ft, Fd '选择所有直线
    
14.     If SS.Count >= 2 Then '检查被加入选择集的直线数量,只有数量大于或等于2时才能检查交点
    9 s  V8 d5 \6 d3 t) `
15.         For I = 0 To SS.Count - 2 '用嵌套循环方式检查某条直线与其它所有直线的交点
    7 r" S1 o3 T$ e7 j1 {; h5 O/ E4 T
16.             For J = I + 1 To SS.Count - 1
      d$ h: F3 h4 m1 O, i" W. L
17.                 V = SS.Item(I).IntersectWith(SS.Item(J), acExtendNone) '获得交点,用两条直线均不延伸的模式
    3 z2 e* W4 h9 P( S* S  }
18.                 If UBound(V) = 2 Then '检查是否有交点
    
19.                     If UBound(P, 2) < 0 Then '重定义数组
    
20.                         ReDim P(2, 0)
    
21.                     Else
    
22.                         ReDim Preserve P(2, UBound(P, 2) + 1)
    ) Z  B. u& ?( ]  T
23.                     End If
    + X% X" B3 V& a2 m1 ]/ D. f  b
24.                     P(0, UBound(P, 2)) = V(0) '把交点坐标存入动态数组
    / ^" Q5 f- _. n
25.                     P(1, UBound(P, 2)) = V(1)
    
26.                     P(2, UBound(P, 2)) = V(2)
    
27.                 End If
    1 b- G; y8 A& k; L5 `
28.             Next
    * ^7 g; g! K+ Z! c" F
29.         Next
    
30.         If UBound(P, 2) < 0 Then
    + u! |+ o8 F  s8 H! a
31.             MsgBox "没有交点", vbOKOnly, "AutoCAD"
    
32.         Else
    
33.             S = "共有 " & UBound(P, 2) + 1 & " 个交点"
    
34.             For I = 0 To UBound(P, 2)
    
35.                 S = S & vbCrLf & P(0, I) & "," & P(1, I) & "," & P(2, I)
    $ S7 n1 V2 [5 O; B5 x1 V  H) b3 I
36.             Next
    
37.             MsgBox S, vbOKOnly, "AutoCAD"
    8 k; ^* y/ v9 y/ F# n1 a
38.         End If
    
39.     Else
    / d  t6 G/ W& Z, u1 d- }
40.         MsgBox "直线少于两条", vbOKOnly, "AutoCAD"
    & X) F' |$ k, i5 D4 p' j0 f. H
41.     End If
    ) W7 z1 d# P8 H
42.     SS.Delete '删除用过的选择集
    ' J- W' r6 C6 l! G0 K# R

复制代码

taqqug

谢谢了,我去研究一下!

taqqug

写得非常详细,非常感激

koutx

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