求两条直线的交点

兰州人

在图上任意做两条相交直线

2. Sub ll()
3.   Dim Ent As AcadEntity
4.   Dim objLine(1) As AcadLine
5.   Dim Pp, Pp1, Pt1, Pt2
6.   With ThisDrawing
7.     ii = 0
8.     For Each Ent In .ModelSpace
9.       Set objLine(ii) = Ent
10.       With objLine(ii)
11.         For jj = 0 To 2
12.           Select Case ii
13.             Case 0
14.               Pt1 = .StartPoint
15.               Kk1 = .Delta(1) / .Delta(0)
16.               .color = 1
17.               yy = Kk1 * (.EndPoint(0) - .StartPoint(0)) + .StartPoint(1)
18.               
19.               'Debug.Print "yy", yy, .EndPoint(1)
20.             Case 1
21.               Pt2 = .StartPoint
22.               Kk2 = .Delta(1) / .Delta(0)
23.               .color = 2
24.           End Select
25.         Next jj
26.       End With
27.       ii = ii + 1
28.     Next Ent
29.     Pp = objLine(0).IntersectWith(objLine(1), acExtendBoth)
30.     Debug.Print Pp(0), Pp(1)
31.     Pp1 = TowLinesIntersect(Pt1, Kk1, Pt2, Kk2)
32.     Debug.Print Pp1(0), Pp1(1)
33.   End With
34. End Sub
35. Function TowLinesIntersect(Pt1, Kk1, Pt2, Kk2) As Variant
36.   Dim Pp(2) As Double
37.   Pp(0) = (Kk1 * Pt1(0) - Pt1(1) - Kk2 * Pt2(0) + Pt2(1)) / (Kk1 - Kk2)
38.   Pp(1) = (Pp(0) - Pt1(0)) * Kk1 + Pt1(1)
39.   TowLinesIntersect = Pp
40. End Function

Sub ll()   Dim Ent As AcadEntity   Dim objLine(1) As AcadLine   Dim Pp, Pp1, Pt1, Pt2   With ThisDrawing     ii = 0     For Each Ent In .ModelSpace       Set objLine(ii) = Ent       With objLine(ii)         For jj = 0 To 2           Select Case ii             Case 0               Pt1 = .StartPoint               Kk1 = .Delta(1) / .Delta(0)               .color = 1               yy = Kk1 * (.EndPoint(0) - .StartPoint(0)) + .StartPoint(1)                              'Debug.Print "yy", yy, .EndPoint(1)             Case 1               Pt2 = .StartPoint               Kk2 = .Delta(1) / .Delta(0)               .color = 2           End Select         Next jj       End With       ii = ii + 1     Next Ent     Pp = objLine(0).IntersectWith(objLine(1), acExtendBoth)     Debug.Print Pp(0), Pp(1)     Pp1 = TowLinesIntersect(Pt1, Kk1, Pt2, Kk2)     Debug.Print Pp1(0), Pp1(1)   End With End Sub Function TowLinesIntersect(Pt1, Kk1, Pt2, Kk2) As Variant   Dim Pp(2) As Double   Pp(0) = (Kk1 * Pt1(0) - Pt1(1) - Kk2 * Pt2(0) + Pt2(1)) / (Kk1 - Kk2)   Pp(1) = (Pp(0) - Pt1(0)) * Kk1 + Pt1(1)   TowLinesIntersect = Pp End Function

kzayy145

支持一下呀，学习了

------------------------------------------------------------------

上海上门按摩  上海上门按摩 上海上门按摩 上海上门按摩 上海按摩

yg545france

怎么回事啊。不能用啊

gdzhou

不是说了要先画两条直线的嘛