请教:如何在插入点自动打断,并使插入块与所插入直线方向一致

Roster · 发表于 2004-9-16 08:01:00

我想在直线上插入一个块,要求能自动打断该直线,并调整块的方向,使之与该直线方向一致,不知如何实现(VBA),请高手指点.先谢谢啦!

雪山飞狐_lzh · 发表于 2004-9-16 15:27:00

Sub ttt45()
   Dim obj As AcadLine, pnt
   Dim objTemp As AcadLine
   Dim minpnt, maxpnt, cenpnt(2) As Double
   Dim objBlock As AcadBlockReference
   Dim height As Double
   Dim pnts(3)
   ThisDrawing.Utility.GetEntity obj, pnt

   temp = ThisDrawing.Utility.PolarPoint(pnt, obj.Angle + Atn(1) * 2, 10)
   Set objTemp = ThisDrawing.ModelSpace.AddLine(pnt, temp)
   pnt = obj.IntersectWith(objTemp, acExtendBoth)
   objTemp.Delete

   Set objBlock = ThisDrawing.ModelSpace.InsertBlock(pnt, "1", 1, 1, 1, 0)
   objBlock.GetBoundingBox minpnt, maxpnt
   cenpnt(0) = (minpnt(0) + maxpnt(0)) / 2
   cenpnt(1) = (minpnt(1) + maxpnt(1)) / 2
   height = maxpnt(1) - minpnt(1)

   objBlock.Move cenpnt, pnt
   objBlock.Rotate pnt, obj.Angle + Atn(1) * 2

   pnts(0) = obj.StartPoint
   pnts(1) = ThisDrawing.Utility.PolarPoint(pnt, obj.Angle, -height / 2)
   pnts(2) = ThisDrawing.Utility.PolarPoint(pnt, obj.Angle, height / 2)
   pnts(3) = obj.EndPoint
   obj.Delete
   ThisDrawing.ModelSpace.AddLine pnts(0), pnts(1)
   ThisDrawing.ModelSpace.AddLine pnts(2), pnts(3)
End Sub