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

taqqug

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

maoyangmy

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

woaishuijia

1. 
   , ]6 {% @( s  ?" _  a- C) X
2.     Dim SS As AcadSelectionSet '声明选择集变量
   
3.     Dim Ft(0) As Integer, Fd(0) As Variant '声明选择集过滤器数组变量
   
4.     Dim P() As Double '声明一个双精度型动态数组,用于保存所有交点坐标
   
5.     Dim V As Variant '声明一个变体型变量,用于提取两直线的交点
   # Z) p) n" D3 ]5 x
6.     Dim I As Long, J As Long '循环变量
   1 S. f$ O8 @7 G$ i7 d2 `, X
7.     Dim S As String '一个字符串,用于消息框
     ]. j1 d1 |9 F# R1 T# c5 q
8.    
   8 T6 m6 g( e  O4 D
9.     On Error Resume Next
   . y" |( R6 {1 f
10.     Set SS = ThisDrawing.SelectionSets.Add("SS" ) '新建选择集
    ! t8 p/ Q: w" y* Y5 F" W! L* ^
11.     Ft(0) = 0 '定义过滤器,组码为0,检查对象类型
    , g0 S/ [) e6 j" G/ j1 A+ ?
12.     Fd(0) = "line" '对象类型为直线
    
13.     SS.Select acSelectionSetAll, , , Ft, Fd '选择所有直线
    - q  {3 O* [7 z4 F% E+ t
14.     If SS.Count >= 2 Then '检查被加入选择集的直线数量,只有数量大于或等于2时才能检查交点
    
15.         For I = 0 To SS.Count - 2 '用嵌套循环方式检查某条直线与其它所有直线的交点
    
16.             For J = I + 1 To SS.Count - 1
    + b8 O( h9 T3 ~6 Q5 C8 C+ D
17.                 V = SS.Item(I).IntersectWith(SS.Item(J), acExtendNone) '获得交点,用两条直线均不延伸的模式
    
18.                 If UBound(V) = 2 Then '检查是否有交点
    
19.                     If UBound(P, 2) < 0 Then '重定义数组
    . s' S- D2 C) h, W3 c; j$ D
20.                         ReDim P(2, 0)
    ' Q3 a- }' T6 X9 C0 w1 ]5 W# J
21.                     Else
    6 D8 p' D4 K4 Q, _
22.                         ReDim Preserve P(2, UBound(P, 2) + 1)
    ! U7 g1 k) }  X+ t3 z0 Y0 A% U
23.                     End If
    5 U8 P0 N0 s2 O1 H8 r5 P
24.                     P(0, UBound(P, 2)) = V(0) '把交点坐标存入动态数组
    
25.                     P(1, UBound(P, 2)) = V(1)
    $ b% }  R4 F* I. m" b8 }$ z( ?" C
26.                     P(2, UBound(P, 2)) = V(2)
    . X. a* {% ~; Y' k0 c' ?
27.                 End If
    
28.             Next
    $ C  z  }/ e4 Q
29.         Next
    
30.         If UBound(P, 2) < 0 Then
    
31.             MsgBox "没有交点", vbOKOnly, "AutoCAD"
    6 j" W3 L# Z( A4 j7 `8 ~
32.         Else
    
33.             S = "共有 " & UBound(P, 2) + 1 & " 个交点"
    7 U+ P; K4 y! r& x) Z' v
34.             For I = 0 To UBound(P, 2)
    3 F4 G7 ?! ^0 J* h3 L% U, D4 l
35.                 S = S & vbCrLf & P(0, I) & "," & P(1, I) & "," & P(2, I)
    
36.             Next
    - ^! e  S! g3 Z" l; F/ I
37.             MsgBox S, vbOKOnly, "AutoCAD"
    : m) ~3 z) T% u  z. y
38.         End If
    9 c, S6 p6 S( d& Q; h2 {( k* h6 u
39.     Else
    
40.         MsgBox "直线少于两条", vbOKOnly, "AutoCAD"
    
41.     End If
    ; O) q  A1 c5 ~+ z1 P# b
42.     SS.Delete '删除用过的选择集
    

复制代码

taqqug

谢谢了,我去研究一下!

taqqug

写得非常详细,非常感激

koutx

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