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

taqqug

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

maoyangmy

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

woaishuijia

1. 
   ; k; x" G, |$ ?" V6 j  F$ x9 o
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 '声明一个变体型变量,用于提取两直线的交点
   : [+ i6 e# K+ Z9 E- w
6.     Dim I As Long, J As Long '循环变量
   2 L9 x9 t* `7 L$ J% k# S
7.     Dim S As String '一个字符串,用于消息框
   
8.    
   3 {! y7 q, X, L. O% K; w. u6 R
9.     On Error Resume Next
   - K- C2 d5 l, q2 f
10.     Set SS = ThisDrawing.SelectionSets.Add("SS" ) '新建选择集
    $ Q5 b6 ^* f) x* o( o
11.     Ft(0) = 0 '定义过滤器,组码为0,检查对象类型
    5 X2 c( b' t! O/ e1 C2 u
12.     Fd(0) = "line" '对象类型为直线
    . Y! \3 \3 Z+ q% n
13.     SS.Select acSelectionSetAll, , , Ft, Fd '选择所有直线
    , s$ P- \/ @* Y9 k6 _7 ]1 b
14.     If SS.Count >= 2 Then '检查被加入选择集的直线数量,只有数量大于或等于2时才能检查交点
    
15.         For I = 0 To SS.Count - 2 '用嵌套循环方式检查某条直线与其它所有直线的交点
    
16.             For J = I + 1 To SS.Count - 1
    : |6 v$ o8 C' l3 r& R+ q5 ]8 u
17.                 V = SS.Item(I).IntersectWith(SS.Item(J), acExtendNone) '获得交点,用两条直线均不延伸的模式
    
18.                 If UBound(V) = 2 Then '检查是否有交点
    / P1 V6 H  B" R7 Z
19.                     If UBound(P, 2) < 0 Then '重定义数组
    
20.                         ReDim P(2, 0)
    3 R% l& R# l: L/ Z! @; y% R
21.                     Else
    % J2 ~/ F4 @' j( ?% ]- x
22.                         ReDim Preserve P(2, UBound(P, 2) + 1)
    
23.                     End If
    6 V* q" T* U, [1 |6 B& a  f" G( g
24.                     P(0, UBound(P, 2)) = V(0) '把交点坐标存入动态数组
    
25.                     P(1, UBound(P, 2)) = V(1)
    0 f3 [, T* u6 R& d9 E0 j
26.                     P(2, UBound(P, 2)) = V(2)
    - W. w& f, h" F7 `4 |$ X% s
27.                 End If
    5 e3 B6 r+ o: Q* K
28.             Next
    5 i# \: h5 W! W: ]! L  g" M. P1 b2 M( `
29.         Next
    
30.         If UBound(P, 2) < 0 Then
    * S. f, M! C9 E* v: \
31.             MsgBox "没有交点", vbOKOnly, "AutoCAD"
    4 a) @8 z" r. j* o, E' N
32.         Else
    % \* S, q$ ]; Z! r& \, B& v
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)
    6 @% @* K; ~7 T+ j
36.             Next
    / a* n/ l# z+ \' W% O
37.             MsgBox S, vbOKOnly, "AutoCAD"
    
38.         End If
    , h$ w3 w7 t# S$ U4 E
39.     Else
    
40.         MsgBox "直线少于两条", vbOKOnly, "AutoCAD"
    * v% z/ M! j* m/ X% x$ l0 |
41.     End If
    + Z5 n( a; e1 n. t+ v
42.     SS.Delete '删除用过的选择集
    $ C# o; L4 Z/ u8 H* }

复制代码

taqqug

谢谢了,我去研究一下!

taqqug

写得非常详细,非常感激

koutx

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