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