用Cad画二次抛物线

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

第一步 确认cad中有VBA module如果没有请下载visual basic编辑器thisdrawing

第二步 打开cadalt+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 Double

Dim (2) As Double

'设抛物线方程为:y=ax2+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 Then 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

'计算x2=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

'画圆锥

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点

pntB(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

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

Else

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

End If

End Sub

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

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

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