[原创]：画抛物线的小程序！

maplesu

这个是一个画抛物线的小程序，输入顶点、二次项系数、开口处的弦长。
画出的抛物线不是样条曲线描点的近似的，而是利用27182818284长老的圆锥剖切而来的，最后旋转确定开口方向！

[PHP]

Sub trparabola()
Dim bq1, bq2, pt1, pt2 As Variant
Dim aa, ll, yy, a1, a2, a3, a4, aa1, pt3(0 To 2), bq4(0 To 2) As Double
Dim bq3(0 To 2) As Double
Dim ae As Double
Dim pt33(0 To 2) As Double
Dim ptarr(0 To 7) As Double
Dim alt As Variant
Dim objboltb As Acad3DSolid
Dim al As Variant
Dim lens As AcadLWPolyline

'求个控制点
bq1 = ThisDrawing.Utility.GetPoint(, "抛物线顶点: ")
aa = ThisDrawing.Utility.GetReal("输入二次项系数： ")
ll = ThisDrawing.Utility.GetDistance(, "输入开口弦长： ")
aa1 = 1 / aa
yy = aa * (ll / 2) ^ 2
a1 = ThisDrawing.Utility.AngleToReal(-30, acDegrees)
a2 = ThisDrawing.Utility.AngleToReal(30, acDegrees)
a3 = ThisDrawing.Utility.AngleToReal(90, acDegrees)
a4 = ThisDrawing.Utility.AngleToReal(150, acDegrees)
bq2 = ThisDrawing.Utility.PolarPoint(bq1, a2, yy)
pt1 = ThisDrawing.Utility.PolarPoint(bq1, a4, aa1)
pt2 = ThisDrawing.Utility.PolarPoint(bq2, a3, aa1)
pt3(0) = pt2(0): pt3(1) = pt1(1): pt3(2) = pt1(2)
bq3(0) = bq2(0): bq3(1) = bq2(1): bq3(2) = bq2(2) + 10
bq4(0) = bq2(0): bq4(1) = bq1(1): bq4(2) = bq1(2)
pt33(0) = 10: pt33(1) = 0: pt33(2) = 0



ptarr(0) = pt1(0)
ptarr(1) = pt1(1)
ptarr(2) = pt2(0)
ptarr(3) = pt2(1)
ptarr(4) = pt3(0)
ptarr(5) = pt3(1)
ptarr(6) = pt1(0)
ptarr(7) = pt1(1)

'画多段线
Set lens = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr)
Dim objlist(0) As AcadEntity
Set objlist(0) = lens

'将多段线变为面域
Dim altregion As AcadRegion
alt = ThisDrawing.ModelSpace.AddRegion(objlist)
objlist(0).Delete
Set altregion = alt(0)

'旋转面域得到圆锥
ae = 2 * Atn(1) * 4
Set objboltb = ThisDrawing.ModelSpace.AddRevolvedSolid(altregion, pt1, pt33, ae)
altregion.Delete

'切圆锥得到抛物线
Set al = objboltb.SectionSolid(bq1, bq2, bq3)
objboltb.Delete
al.Rotate bq1, a1
al.Rotate3D bq1, bq4, a3
Dim explodedobjects As Variant
explodedobjects = al.Explode
al.Delete
Dim i As Integer
Dim kind As String
Dim parabolaobject As AcadSpline
For i = 0 To UBound(explodedobjects)
kind = explodedobjects(i).ObjectName
If kind = "AcDbLine" Then
   explodedobjects(i).Delete
   Else
     Set parabolaobject = explodedobjects(i)
   End If
Next

'旋转抛物线
ThisDrawing.SendCommand "rotate" & vbCr & "(Handent """ & parabolaobject.Handle & """)" & vbCr & "" & vbCr & bq1(0) & "," & bq1(1) & vbCr

End Sub

[/PHP]

陌生人

听起来挺有创意，有时间再好好研究下。：）

雪山飞狐(lzh)

第一次调用会加载建模Dll速度有点慢，有什么好办法解决呢，另外和是样条曲线描点的近似的曲线有什么区别麽？

maplesu

因为才学vba没有多久，所以对于加载速度慢，我现在的能力是没有办法解决了！

对于其和样条曲线描点的近似的曲线的区别就是这个是由圆锥切来的，应该说是一个准确的抛物线了，而不是近似的！

这个其实长不大斑主已经写过一个.NET的在2005上用的，我只是因为刚学vba用来练练手！