用Cad画二次抛物线

本文格式为Word版，下载可任意编辑——用Cad画二次抛物线Cad画二次抛物线如

第一步确认cad中有假使没有请下载，即CAD中“工具〞→“宏〞→“visualbasic编辑器〞，点thisdrawing其次步开启开启VBA窗口添加模块复制以下Subpwx()'定义几个点

DimpntO(2)AsDoubleDimpntA(2)AsDoubleDimpntB(2)AsDoubleDimpntC(2)AsDoubleDimpntD(2)AsDoubleDimpntE(2)AsDouble

'设抛物线方程为:y=ax2+bx+cDimaAsDoubleDimbAsDoubleDimcAsDouble'设抛物线的宽度为lDimlAsDoubleDimpAsDouble

DimCoAsAcad3DSolidDimSeAsAcadRegionDimPaAsAcad3DFaceDimPntAsAcadPointDimSp()AsAcadObject

a=InputBox(\请输入y=a*x*x+b*x+c中对应的a:\抛物线方程参数\Ifa=0ThenMsgBox\不是抛物线\

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'计算x2=2py中的pp=1/Abs(a)'定义O点pntO(0)=0pntO(1)=0pntO(2)=0

'定义A点pntA(0)=0

pntA(1)=0

pntA(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/2

pntA(2)=(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时,翻转曲线

Ifa>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.Delete

Se.DeleteSp(1).Delete

Else

MsgBox\输入的l太小,不适合剥圆锥\EndIf

EndSub

第三步菜单栏里点击运行命令输入参数

以及抛物线宽度即可得到

CAD和ExcelVBA高手请进批量获取坐标点数据

一次出差到一个项目工地去,看到他们对着电脑上设计单位给的CAD图在一个点一个点的的找坐标值.方法是用鼠标点上一个点,记录下来(X,Y)后再输到EXCEL中,怕一个人出错,得两个人来操作.后来有人发现了一个好方法,说不用笔来记(X,Y)了,直接用复制和粘贴的方法来做,这确实是一大进步呀.我问他们这一晚上能找多少点呀,回复说做不了多少还老出错.我说这样吧我给你编一个小程序用吧.一晚过后其次天他们拿程序一用都说真是省大劲了,又准又快呀.

在CAD中选工具--宏--visualbasic编辑器,点thisdrawing把下面的程序写进去,然后点运行即可.

AttributeVB_Name=\模块1\Subabc()

Dimx,yAsDouble

DimReturnPointAsVariantDimiAsIntegerDimhighAsSingle

DimPtext,FnameAsStringDimtextObjAsAcadTextDimpointObjAsAcadPointDimlayerObjAsAcadLayerx=0:y=0:i=1:high=9

Fname=InputBox(\选取终止时，请回到第一点！请给出文件名。\IfFname=\Fname=\

SetlayerObj=ThisDrawing.Layers