用Cad画二次抛物线

Cad画二次抛物线如

第一步确认cad中有如果没有请下载，即CAD中“工具”→“宏”→“visual basic编辑器”，点thisdrawing 第二步打开打开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 pntE(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 \不是抛物线\

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

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

以及抛物线宽度即可得到

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

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

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

Attribute VB_Name = \模块1\Sub abc()

Dim x, y As Double

Dim ReturnPoint As Variant Dim i As Integer Dim high As Single

Dim Ptext, Fname As String Dim textObj As AcadText Dim pointObj As AcadPoint Dim layerObj As AcadLayer x = 0: y = 0: i = 1: high = 9

Fname = InputBox(\选取结束时，请回到第一点！请给出文件名。\If Fname = \Fname = \

Set layerObj = ThisDrawing.Layers.Add(\

ReturnPoint = ThisDrawing.Utility.GetPoint

Ptext = i & \Set textObj = ThisDrawing.ModelSpace.AddText(Ptext, ReturnPoint, high) Set pointObj = ThisDrawing.ModelSpace.AddPoint(ReturnPoint) pointObj.Layer = \textObj.Layer = \pointObj.color = acRed

Open Fname For Output As #1 '\Print #1, \

Print #1, i; Round(ReturnPoint(1), 2), Round(ReturnPoint(0), 2)

本文来源：https://www.bwwdw.com/article/fnq8.html