本帖最后由 作者 于 2007-2-9 19:19:43 编辑
Option Explicit Public Sub Sample() Dim objline As AcadLine Dim lineObj As AcadLine Dim returnPnt As Variant Dim sp(0 To 2) As Double Dim ep(0 To 2) As Double Dim ang As Double Dim pt(0 To 2) As Double Const pi = 3.14159 '1. 一条线两端点坐标(x1,y1);(x2,y2) :设该直线为objline ' 如果只有两端点坐标(x1,y1);(x2,y2), 可用 addline 方法画出该直线 ThisDrawing.Utility.GetEntity objline, pt, "Select a line" ang = objline.Angle returnPnt = ThisDrawing.Utility.GetPoint(, "Enter a point: ") sp(0) = returnPnt(0) sp(1) = returnPnt(1) sp(2) = returnPnt(2) '2.做直线objline的垂线lineObj ep(0) = sp(0) + Cos(ang + pi / 2) ep(1) = sp(1) + Sin(ang + pi / 2) ep(2) = sp(2) Set lineObj = ThisDrawing.ModelSpace.AddLine(sp, ep) '3.找出直线objline和它的垂线lineObj的交点pt returnPnt = lineObj.IntersectWith(objline, acExtendNone) If VarType(returnPnt) <> vbEmpty Then If LBound(returnPnt) <= UBound(returnPnt) Then pt(0) = returnPnt(0) pt(1) = returnPnt(1) pt(2) = returnPnt(2) End If End If returnPnt = lineObj.IntersectWith(objline, acExtendBoth) If VarType(returnPnt) <> vbEmpty Then If LBound(returnPnt) <= UBound(returnPnt) Then pt(0) = returnPnt(0) pt(1) = returnPnt(1) pt(2) = returnPnt(2) End If End If lineObj.Delete '4.画垂线 Dim obj1 As AcadLine Set obj1 = ThisDrawing.ModelSpace.AddLine(sp, pt) End Sub
|