《用Cad畫二次拋物線》由會員分享，可在線閱讀，更多相關(guān)《用Cad畫二次拋物線（4頁珍藏版）》請在裝配圖網(wǎng)上搜索。
1、Cad畫二次拋物線如 y=ax2+bx+c
—“visual
第一步 確認(rèn)cad中有VBAmodule如果沒有請下載，即CAD中“工具”-“宏
basic 編輯器”,點 thisdrawing
第二步 打開cad alt+F11打開VBA窗口 添加模塊 復(fù)制以下
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 設(shè)拋物線方程為
2、:y=ax今bx+c
Dim a As Double
Dim b As Double
Dim c As Double
設(shè)拋物線的寬度為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 中對應(yīng)的a:"," 拋物線方程參數(shù)")
If a = 0 Then MsgBox "a=0, 不是拋
3、物線":End
拋物線方程參數(shù)")
拋物線方程參數(shù)")
b = InputBox(" 請輸入 y=a*x*x+b*x+c 中對應(yīng)的 b:"," c = InputBox(" 請輸入 y=a*x*x+b*x+c 中對應(yīng)的 c:","
l = InputBox(" 請輸入所要畫的拋物線寬度 l:"," 拋物線寬度")
l = l / 2 計算x2=2py中的p
p = 1 / Abs(a)
’定義。點
pntO(0) = 0
pntO(1) = 0
pntO(2) = 0 定義 A 點 pntA(0) = 0
精品資料
pntA⑴=0
pntA(2) = l * Sq
4、r(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
5、畫剝面線
Set Se = Co.SectionSolid(pntA, pntB, pntC)
‘剝面線旋轉(zhuǎn)到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
當(dāng)a>0時，翻轉(zhuǎn)曲線
If a > 0 Then Se.Rotate3D pntO, pntE, 180 * 4
6、* Atn(1) / 180
’重新設(shè)巳嵐
pntE(0) = -b / (2 * a)
pntE(1) = (4 * a * c - b A 2) / (4 * a)
pntE(2) = 0
移拋物線
Se.MovepntO, pntE
炸開剝面線
Sp = Se.Explode
刪除輔助內(nèi)容
Co.Delete
Se.Delete
Sp(1).Delete
Else
MsgBox "輸入的l太小，不適合剝圓錐"
End If
End Sub
第三步 菜單欄里點擊運行命令 輸入?yún)?shù)a b c以及拋物線寬度即可得到
CADf口 Excel VBA高手請進 批
7、量獲取坐標(biāo)點數(shù)據(jù)
一次出差到一個項目工地去 ，看到他們對著電腦上設(shè)計單位給的 CAD圖在一個點一個點的的
找坐標(biāo)值.方法是用鼠標(biāo)點上一個點，記下(X,Y)后再輸?shù)紼XCEL中，怕一個人出錯，得兩個人 來操作.后來有人發(fā)現(xiàn)了一個好辦法 ，說不用筆來記(X,Y) 了，直接用復(fù)制和粘貼的辦法來做
這確實是一大進步呀.我問他們這一晚上能找多少點呀 ，回答說做不了多少還老出錯 .我說
這樣吧我給你編一個小程序用吧.一晚過后第二天他們拿程序一用都說真是省大勁了 ，又準(zhǔn)
又快呀.
在CAD43選 工具-宏--visual basic 編輯器，點thisdrawing 把下面的程序?qū)戇M去，然
后
8、點運行即可.
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("選取結(jié)束時，請回到第一點！請給出文件名。
9、")
If Fname = "" Then Fname = "PointsDate"
Fname = "c:\abc\" & Fname & ".txt"
Set layerObj = ThisDrawing.Layers.Add("PointsData")
ReturnPoint = ThisDrawing.Utility.GetPoint
Ptext = i & ":(" & Round(ReturnPoint(0), 2) & "," & Round(ReturnPoint(1), 2) & ")
Set textObj = ThisDrawing.ModelSpace.Ad
10、dText(Ptext, ReturnPoint, high)
Set pointObj = ThisDrawing.ModelSpace.AddPoint(ReturnPoint)
pointObj.Layer = "PointsData"
textObj.Layer = "PointsData"
pointObj.color = acRed
Open Fname For Output As #1 "c:\PointsDATA.txt"
Print #1, "No", "y", "x"
Print #1, i; Round(ReturnPoint⑴，2), Round(ReturnPoint(0), 2)
Welcome To
Download !!!
歡迎您的下載，資料僅供參考！
用Cad畫二次拋物線
