用Cad画二次抛物线.doc

用Cad画二次抛物线.doc

《用Cad画二次抛物线.doc》由会员分享，可在线阅读，更多相关《用Cad画二次抛物线.doc（4页珍藏版）》请在冰豆网上搜索。

Cad画二次抛物线如y=ax2+bx+c

第一步确认cad中有VBAmodule如果没有请下载，即CAD中“工具”→“宏”→“visualbasic编辑器”，点thisdrawing

第二步打开cadalt+F11打开VBA窗口添加模块复制以下

Subpwx（）

'定义几个点

DimpntO

（2）AsDouble

DimpntA

（2）AsDouble

DimpntB

（2）AsDouble

DimpntC

（2）AsDouble

DimpntD

（2）AsDouble

DimpntE

（2）AsDouble

'设抛物线方程为:

y=ax²+bx+c

DimaAsDouble

DimbAsDouble

DimcAsDouble

'设抛物线的宽度为l

DimlAsDouble

DimpAsDouble

DimCoAsAcad3DSolid

DimSeAsAcadRegion

DimPaAsAcad3DFace

DimPntAsAcadPoint

DimSp（）AsAcadObject

a=InputBox（"请输入y=a*x*x+b*x+c中对应的a:

","抛物线方程参数"）

Ifa=0ThenMsgBox"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）=0

pntO

（1）=0

pntO

（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,pntA

Ifl>p/2Then

'定义A点pntA（0）=0

pntA

（1）=p/2

pntA

（2）=（l-p/2）*Sqr（3）

'定义B点

pntB（0）=0

pntB

（1）=-l+p

pntB

（2）=0

'定义C点

pntC（0）=1

pntC

（1）=-l+p

pntC

（2）=0

'画剥面线

SetSe=Co.SectionSolid（pntA,pntB,pntC）

'剥面线旋转到xy平面

Se.Rotate3DpntB,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

'移动剥面线,使顶点在（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.Delete

Sp

（1）.Delete

Else

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

EndIf

EndSub

第三步菜单栏里点击运行命令输入参数abc以及抛物线宽度即可得到

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

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

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

AttributeVB_Name="模块1"

Subabc（）

Dimx,yAsDouble

DimReturnPointAsVariant

DimiAsInteger

DimhighAsSingle

DimPtext,FnameAsString

DimtextObjAsAcadText

DimpointObjAsAcadPoint

DimlayerObjAsAcadLayer

x=0:

y=0:

i=1:

high=9

Fname=InputBox（"选取结束时，请回到第一点！

请给出文件名。

"）

IfFname=""ThenFname="PointsDate"

Fname="c:

\abc\"&Fname&".txt"

SetlayerObj=ThisDrawing.Layers.Add（"PointsData"）

ReturnPoint=ThisDrawing.Utility.GetPoint

Ptext=i&":

（"&Round（ReturnPoint（0）,2）&","&Round（ReturnPoint

（1）,2）&"）"

SettextObj=ThisDrawing.ModelSpace.AddText（Ptext,ReturnPoint,high）

SetpointObj=ThisDrawing.ModelSpace.AddPoint（ReturnPoint）

pointObj.Layer="PointsData"

textObj.Layer="PointsData"

pointObj.color=acRed

OpenFnameForOutputAs#1'"c:

\PointsDATA.txt"

Print#1,"No","y","x"

Print#1,i;Round（ReturnPoint

（1）,2）,Round（ReturnPoint（0）,2）