用Cad画二次抛物线.doc

《用Cad画二次抛物线.doc》由会员上传分享，免费在线阅读，更多相关内容在工程资料-天天文库。

1、Cad画二次抛物线如y=ax2+bx+c第一步确认cad中有VBAmodule如果没有请下载，即CAD中“工具”→“宏”→“visualbasic编辑器”，点thisdrawing第二步打开cadalt+F11打开VBA窗口添加模块复制以下Subpwx()'定义几个点DimpntO(2)AsDoubleDimpntA(2)AsDoubleDimpntB(2)AsDoubleDimpntC(2)AsDoubleDimpntD(2)AsDoubleDimpntE(2)AsDouble'设抛物线方程为:y=ax²+bx+cDimaAsDoubleDimbAsD

2、oubleDimcAsDouble'设抛物线的宽度为lDimlAsDoubleDimpAsDoubleDimCoAsAcad3DSolidDimSeAsAcadRegionDimPaAsAcad3DFaceDimPntAsAcadPointDimSp()AsAcadObjecta=InputBox("请输入y=a*x*x+b*x+c中对应的a:","抛物线方程参数")Ifa=0ThenMsgBox"a=0,不是抛物线":Endb=InputBox("请输入y=a*x*x+b*x+c中对应的b:","抛物线方程参数")c=InputBox("请输入y=a*x*x+b*x+

3、c中对应的c:","抛物线方程参数")l=InputBox("请输入所要画的抛物线宽度l:","抛物线宽度")l=l/2'计算x²=2py中的pp=1/Abs(a)'定义O点pntO(0)=0pntO(1)=0pntO(2)=0'定义A点pntA(0)=0pntA(1)=0pntA(2)=l*Sqr(3)/2'画圆锥SetCo=ThisDrawing.ModelSpace.AddCone(pntO,l,l*Sqr(3))'移动圆锥,使底部圆在xy平面上Co.MovepntO,pntAIfl>p/2Then'定义A点pntA(0)=0pntA(1)=p/2pntA(2)=

4、(l-p/2)*Sqr(3)'定义B点pntB(0)=0pntB(1)=-l+ppntB(2)=0'定义C点pntC(0)=1pntC(1)=-l+ppntC(2)=0'画剥面线SetSe=Co.SectionSolid(pntA,pntB,pntC)'剥面线旋转到xy平面Se.Rotate3DpntB,pntC,-60*4*Atn(1)/180'定义D点pntD(0)=0pntD(1)=-lpntD(2)=0'定义E点pntE(0)=1pntE(1)=0pntE(2)=0'移动剥面线,使顶点在(0,0,0)位置Se.MovepntO,pntD'当a>0时,翻转曲线If

5、a>0ThenSe.Rotate3DpntO,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.DeleteSe.DeleteSp(1).DeleteElseMsgBox"输入的l太小,不适合剥圆锥"EndIfEndSub第三步菜单栏里点击运行命令输入参数abc以及抛物线宽度即可得到CAD和ExcelVBA高手请进批量获取坐标点数据一次出差到一个项目工地去,看到

6、他们对着电脑上设计单位给的CAD图在一个点一个点的的找坐标值.方法是用鼠标点上一个点,记下(X,Y)后再输到EXCEL中,怕一个人出错,得两个人来操作.后来有人发现了一个好办法,说不用笔来记(X,Y)了,直接用复制和粘贴的办法来做,这确实是一大进步呀.我问他们这一晚上能找多少点呀,回答说做不了多少还老出错.我说这样吧我给你编一个小程序用吧.一晚过后第二天他们拿程序一用都说真是省大劲了,又准又快呀.在CAD中选工具--宏--visualbasic编辑器,点thisdrawing把下面的程序写进去,然后点运行即可.AttributeVB_Name="模块1"Subabc()

7、Dimx,yAsDoubleDimReturnPointAsVariantDimiAsIntegerDimhighAsSingleDimPtext,FnameAsStringDimtextObjAsAcadTextDimpointObjAsAcadPointDimlayerObjAsAcadLayerx=0:y=0:i=1:high=9Fname=InputBox("选取结束时，请回到第一点！请给出文件名。")IfFname=""ThenFname="PointsDate"Fname="c:abc"&Fname&".txt"Setla