社区 › VB › 求两条直线的交点

兰州人 发表于 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

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

查看完整版本: 求两条直线的交点