用Cad画二次抛物线(共4页)

1、精选优质文档-倾情为你奉上Cad画二次抛物线如y=ax2+bx+c 第一步 确认cad中有VBA module如果没有请下载，即CAD中“工具”“宏”“visual basic编辑器”，点thisdrawing第二步 打开cadalt+F11打开VBA窗口添加模块复制以下 Sub pwx() '定义几个点 Dim pntO(2) As Double Dim pntA(2) As Double Dim pntB(2) As Double Dim pntC(2) As Double Dim pntD(2) As DoubleDim pntE(2) As Double '设抛物线方程

2、为:y=ax²+bx+c Dim a As Double Dim b As Double Dim c As Double '设抛物线的宽度为l Dim l As Double Dim p As Double Dim Co As Acad3DSolid Dim Se AsAcadRegion Dim Pa As Acad3DFace Dim PntAsAcadPoint Dim Sp() As AcadObject a = InputBox("请输入y=a*x*x+b*x+c中对应的a:", "抛物线方程参数") If a = 0 The

3、n MsgBox "a=0, 不是抛物线": End b = InputBox("请输入y=a*x*x+b*x+c中对应的b:", "抛物线方程参数") c = InputBox("请输入y=a*x*x+b*x+c中对应的c:", "抛物线方程参数") l = InputBox("请输入所要画的抛物线宽度l:", "抛物线宽度") l = l / 2 '计算x²=2py中的p p = 1 / Abs(a) '定义O点 pntO(0

4、) = 0 pntO(1) = 0 pntO(2) = 0 '定义A点 pntA(0) = 0 pntA(1) = 0 pntA(2) = l * Sqr(3) / 2 '画圆锥 Set Co = ThisDrawing.ModelSpace.AddCone(pntO, l, l * Sqr(3) '移动圆锥,使底部圆在xy平面上 Co.MovepntO, pntA If l > p / 2 Then '定义A点 pntA(0) = 0 pntA(1) = p / 2 pntA(2) = (l - p / 2) * Sqr(3) '定义B点 pnt

5、B(0) = 0 pntB(1) = -l + p pntB(2) = 0 '定义C点 pntC(0) = 1 pntC(1) = -l + p pntC(2) = 0 '画剥面线 Set Se = Co.SectionSolid(pntA, pntB, pntC) '剥面线旋转到xy平面 Se.Rotate3D pntB, pntC, -60 * 4 * Atn(1) / 180'定义D点 pntD(0) = 0 pntD(1) = -l pntD(2) = 0 '定义E点 pntE(0) = 1 pntE(1) = 0 pntE(2) = 0 

6、9;移动剥面线,使顶点在(0,0,0)位置 Se.MovepntO, pntD '当a>0时,翻转曲线 If a > 0 Then Se.Rotate3D pntO, pntE, 180 * 4 * Atn(1) / 180 '重新设E点 pntE(0) = -b / (2 * a) pntE(1) = (4 * a * c - b 2) / (4 * a) pntE(2) = 0 '移抛物线 Se.MovepntO, pntE '炸开剥面线 Sp = Se.Explode '删除辅助内容 Co.Delete Se.Delete Sp(1).

7、Delete Else MsgBox "输入的l太小,不适合剥圆锥" End If End Sub 第三步 菜单栏里点击运行命令输入参数abc以及抛物线宽度即可得到 一次出差到一个项目工地去,看到他们对着电脑上设计单位给的CAD图在一个点一个点的的找坐标值.方法是用鼠标点上一个点,记下(X,Y)后再输到EXCEL中,怕一个人出错,得两个人来操作. 后来有人发现了一个好办法,说不用笔来记(X,Y)了,直接用复制和粘贴的办法来做,这确实是一大进步呀.我问他们这一晚上能找多少点呀, 回答说做不了多少还老出错. 我说这样吧我给你编一个小程序用吧. 一晚过后第二天他们拿程序一用都说真

8、是省大劲了,又准又快呀.在CAD中 选 工具-宏-visual basic编辑器, 点thisdrawing 把下面的程序写进去, 然后点运行即可.Attribute VB_Name = "模块1"Sub abc()Dim x, y As DoubleDim ReturnPoint As VariantDim i As IntegerDim high As SingleDim Ptext, Fname As StringDim textObj As AcadTextDim pointObj As AcadPointDim layerObj As AcadLayerx = 0

9、: y = 0: i = 1: high = 9Fname = InputBox("选取结束时，请回到第一点！请给出文件名。")If Fname = "" Then Fname = "PointsDate"Fname = "c:abc" & Fname & ".txt"Set layerObj = ThisDrawing.Layers.Add("PointsData")ReturnPoint = ThisDrawing.Utility.GetPointPtex

10、t = i & ":(" & Round(ReturnPoint(0), 2) & "," & Round(ReturnPoint(1), 2) & ")"Set textObj = ThisDrawing.ModelSpace.AddText(Ptext, ReturnPoint, high)Set pointObj = ThisDrawing.ModelSpace.AddPoint(ReturnPoint)pointObj.Layer = "PointsData"textObj.Layer = "PointsData"pointObj.color = acRedOpen Fname For Output As