|
|
发表于 2004-6-3 21:34:00
|
显示全部楼层
Dim DaoJu As Variant
Dim D0, D1, D2, D3, D4, D5, n1, r1, r2, l0, l1, l2, l3, l4, l5 As Double '轴结构参数
Const Pi = 3.141592 '圆周率
Dim AcadApp As AcadApplication
Sub ConnectCAD()
On Error Resume Next
Err.Clear
Set AcadApp = GetObject(, "AutoCAD.Application")
If Err.Number Then
' MsgBox Err.Description
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application")
If Err.Number Then
MsgBox Err.Description
Exit Sub
End If
End If
AcadApp.Visible = True
AcadApp.WindowState = AutoCAD.AcWindowState.acMax
AppActivate (AcadApp.Caption)
End Sub
Private Sub Command1_Click()
Call ConnectCAD
'遍历模型空间的所有成员，删除一切实体
Dim Entry As AutoCAD.AcadEntity
For Each Entry In AcadApp.ActiveDocument.ModelSpace
Entry.Delete
Next
'设置三维视点
Dim NewDirection(2) As Double
NewDirection(0) = 1: NewDirection(1) = 0.5: NewDirection(2) = 0.5
AcadApp.ActiveDocument.ActiveViewport.Direction = NewDirection
AcadApp.ActiveDocument.Layers.Item(0).Color = AutoCAD.AcColor.acRed '层0设为红色
AcadApp.ActiveDocument.SendCommand ("_Shademode" + vbCr + "_G" + vbCr) '着色
'轴输入参数
D2 = Val(Me.Text1.Text)
l2 = Val(Me.Text2.Text)
'轴毛坯参数
D0 = D2 - 15
D1 = D2 - 5
D3 = D2 + 12
D4 = D3 - 5
D5 = D1
n1 = 2
r1 = 1.6
r2 = 2
Dim plineObj(1) As AutoCAD.AcadLWPolyline
Dim points(31) As Double
points(0) = 0: points(1) = 6 '1点的X，Y坐标
points(2) = D0 / 2 - n1: points(3) = 0 '2点
points(4) = points(2) + n1: points(5) = n1 '3点
points(6) = points(4): points(7) = l0 - r1 '4点
points(8) = D1 / 2: points(9) = points(7) + r1 '5点
points(10) = points(8): points(11) = l0 + l1 - r2 '6点
points(12) = D1 / 2: points(13) = points(11) + r2 '7点
points(14) = points(12): points(15) = points(13) + l2 - r2 '8点
points(16) = D3 / 2: points(17) = points(15) + r2 '9点
points(18) = points(16): points(19) = points(17) + l3 '10点
points(20) = D4 / 2: points(21) = points(19) + r2 '11点
points(22) = points(20): points(23) = points(21) + l4 '12点
points(24) = D5 / 2: points(25) = points(23) + r2 '13点
points(26) = points(24): points(27) = points(25) + l5 - n1 '14点
points(28) = points(26) - n1: points(29) = points(27) + n1 '15点
points(30) = 0: points(31) = points(29) '16点
'points(32) = points(16): points(33) = points(17) + l3 '17点
'points(34) = points(16): points(35) = points(17) + l3 '18点
'points(36) = points(16): points(37) = points(17) + l3 '19点
'points(38) = points(16): points(39) = points(17) + l3 '20点
'points(40) = points(16): points(41) = points(17) + l3 '21点
'points(42) = points(16): points(43) = points(17) + l3 '22点
Set plineObj(0) = AcadApp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points)
plineObj(0).Closed = True
'镜象1－10点围成的图形
Dim point1(2) As Double
Dim point2(2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 0: point2(1) = 1: point2(2) = 0
Set plineObj(1) = plineObj(0).Mirror(point1, point2)
'创建为面域
Dim regionObj As Variant
regionObj = AcadApp.ActiveDocument.ModelSpace.AddRegion(plineObj)
'布尔加运算
regionObj(0).Boolean AutoCAD.AcBooleanType.acUnion, regionObj(1)
'旋转面域
Dim axisPt(2) As Double
Dim axisDir(2) As Double
Dim angle As Double
axisPt(0) = 0: axisPt(1) = 0: axisPt(2) = 0
axisDir(0) = 1: axisDir(1) = 0: axisDir(2) = 0
angle = 2 * Pi
Dim solidObj As AutoCAD.Acad3DSolid
Set solidObj = AcadApp.ActiveDocument.ModelSpace.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle)
AcadApp.ZoomExtents
'沿Y轴旋转90度
Dim rotatePt1(2) As Double
Dim rotatePt2(2) As Double
Dim rotateAngle As Double
rotatePt1(0) = 0: rotatePt1(1) = 0: rotatePt1(2) = 0
rotatePt2(0) = 0: rotatePt2(1) = 1: rotatePt2(2) = 0
rotateAngle = 90
rotateAngle = rotateAngle * Pi / 180#
solidObj.Rotate3D rotatePt1, rotatePt2, rotateAngle
'键
Dim boxobj As AutoCAD.Acad3DSolid
Dim length As Double, width As Double, height As Double
Dim center(2) As Double
center(0) = 0: center(1) = -D4 / 2: center(2) = 0
length = D4 * 0.3: width = D4 * 0.3: height = B * 1.1
Set boxobj = AcadApp.ActiveDocument.ModelSpace.AddBox(center, length, width, height)
solidObj.Boolean AutoCAD.AcBooleanType.acSubtraction, boxobj
Dim i As Integer
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Me.Caption = "轴"
Me.Label1.Caption = "D2"
Me.Label2.Caption = "l2"
'Me.Label3.Caption = "压力角Af"
'Me.Label4.Caption = "轴径D4"
'赋初值
Me.Text1.Text = 75 'd2
Me.Text2.Text = 82 'l2
Me.Command1.Caption = "轴结构造型"
Me.Command2.Caption = "结束"
End Sub
|
|
置顶卡
