急！有偿！[求助]

liuyuabc

轴和轴承的ＶＢ三维造型程序！ＣＡＤ的二次开发！后天要交！

雪山飞狐_lzh

这个，最好你自己先编一个原型，看看有什么不懂再。。。

liuyuabc

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

liuyuabc

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

liuyuabc

轴承的我不会呀！麻烦高手帮个忙！上面是轴和垫片的程序！轴的长度尺寸可以自己定！谢谢！

雪山飞狐_lzh

轴和轴承有区别麽？应该原理差不多吧，既然轴都编出来了，轴承应该对你来说不难吧