求两条直线的交点

兰州人 发表于 2009-9-11 12:05:00

在图上任意做两条相交直线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 发表于 2009-9-17 13:56:00

支持一下呀，学习了------------------------------------------------------------------上海上门按摩  上海上门按摩 上海上门按摩 上海上门按摩 上海按摩

yg545france 发表于 2010-2-8 19:40:00

怎么回事啊。不能用啊

gdzhou 发表于 2010-2-23 18:34:00

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

页: [1]

明经CAD社区's Archiver

求两条直线的交点