[分享]激情奉献——齿轮的参数绘制！！

gzy

经常有人问，我也来搞搞！！！！可能有人会觉得用ACAD来做是自讨苦吃，没办法 ！我只懂这个。利用VB.NET开发ACAD一实例改编而成，目前还不是很完善，欲打算添加斜齿轮，内齿轮等部分。希望大家一起学习和完善！！！！！ 'by gzy e-mail:gzy@mjtd.com
Dim 刀具 As Variant
Dim Da, D0, D1, D2, D3, D4, n1, B, C As Double '齿数结构参数
Dim Z, m, Af As Double '齿数、模数、压力角
Const Pi = 3.141592 '圆周率 Private Sub CommandButton1_Click()
clForm1.Hide '设置三维视点
Dim NewDirection(2) As Double
NewDirection(0) = 1: NewDirection(1) = 0.5: NewDirection(2) = 0.5
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport ThisDrawing.Layers.Item(0).color = AutoCAD.AcColor.acBlue '颜色 ThisDrawing.SendCommand ("_Shademode" + vbCr + "_G" + vbCr) '着色 ' '齿轮输入参数
Z = Val(Me.TextBox1.Text) '齿数
m = Val(Me.TextBox2.Text) '模 数
Af = Val(Me.TextBox3.Text) * Pi / 180 '压力角 '齿轮毛坯造型 Da = m * Z + 2 * m
D4 = Val(Me.TextBox4.Text) '轴径
D3 = Val(Me.TextBox7.Text)
D0 = Val(Me.TextBox6.Text)
D1 = (D0 + D3) / 2
D2 = (D0 - D3) * 0.3 B = Val(Me.TextBox5.Text) '齿宽
C = 0.2 * B
n1 = 0.5 * m
If Da <= 160 Then C = B: D0 = (Da + D4) / 2: D3 = D0: D2 = 0: Me.CheckBox1.Value = False Dim plineObj(1) As AcadLWPolyline
Dim points(19) As Double
'定义2D多义线点
points(0) = 0: points(1) = D4 / 2 '1点的X，Y坐标
points(2) = B / 2 - n1: points(3) = points(1) '2点
points(4) = points(2) + n1: points(5) = points(3) + n1 '3点
points(6) = points(4): points(7) = D3 / 2 '4点
points(8) = C / 2: points(9) = points(7) + n1 '5点
points(10) = points(8): points(11) = D0 / 2 - n1 '6点
points(12) = points(6): points(13) = points(11) + n1 '7点
points(14) = points(12): points(15) = Da / 2 - n1 '8点
points(16) = points(14) - n1: points(17) = points(15) + n1 '9点
points(18) = 0: points(19) = points(17) '10点
'创建AddLightWeightPolyline多义线
Set plineObj(0) = ThisDrawing.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 = ThisDrawing.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 Acad3DSolid
Set solidObj = ThisDrawing.ModelSpace.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle) ' ThisDrawing.ModelSpace.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 = ThisDrawing.ModelSpace.AddBox(center, length, width, height)
solidObj.Boolean AutoCAD.AcBooleanType.acSubtraction, boxObj Dim i As Integer '腹板孔
If Me.CheckBox1.Value = True Then
Dim cylinderObj As Acad3DSolid
Dim radius As Double
center(0) = 0#: center(1) = D1 / 2: center(2) = 0#
radius = D2 / 2
height = C * 1.1
Set cylinderObj = ThisDrawing.ModelSpace.AddCylinder(center, radius, height) '环形阵列
Dim retObj As Variant
Dim basePnt(2) As Double
basePnt(0) = 0: basePnt(1) = 0: basePnt(2) = 0#
retObj = cylinderObj.ArrayPolar(7, 2 * Pi, basePnt) For i = 0 To 5
solidObj.Boolean AutoCAD.AcBooleanType.acSubtraction, retObj(i)
Next i
End If Call 齿轮刀具 For i = 0 To Z - 1
solidObj.Boolean AutoCAD.AcBooleanType.acSubtraction, 刀具(i)
Next i ' 遍历模型空间的所有成员，删除非齿轮结构实体的一切实体
For Each entry In ThisDrawing.ModelSpace
If entry.ObjectID <> solidObj.ObjectID Then
entry.Delete
End If
Next solidObj.Update
clForm1.Hide
End Sub Private Sub CommandButton2_Click()
End
End Sub '齿轮结构造型
Sub 齿轮刀具()
Dim R, Rf, Rb, Ra As Single R = m * Z / 2 '齿轮分度圆半径
Rf = (R - 1.25 * m) '齿轮根圆半径
Rb = R * Cos(Af) '齿轮基圆半径
Ra = R + m ' 齿轮顶圆半径 '根据渐开线公式,计算渐开线上各点坐标
Dim Sb, th(3)
Sb = Cos(Af) * (3.14 * m / 2 + m * Z * (Tan(Af) - (Af))) ' 齿轮基圆齿厚
th(1) = (3.14 * m * Cos(Af) - Sb) / (2 * Rb)
th(0) = th(1) / 3
th(2) = th(1) + Tan(Af) - Af
th(3) = th(1) + Tan(Acos(Rb / Ra)) - Acos(Rb / Ra) Dim curves(5) As AutoCAD.AcadEntity
Dim points0(5) As Double
Dim points1(8) As Double
Dim points2(5) As Double points0(0) = 0: points0(1) = Rf '第0点
points0(2) = Rf * Sin(th(0)): points0(3) = Rf * Cos(th(0)) '第1点
points0(4) = Rb * Sin(th(1)): points0(5) = Rb * Cos(th(1)) '第2点 Dim startTan(2) As Double
Dim endTan(2) As Double
startTan(0) = 0: startTan(1) = 0: startTan(2) = 0
endTan(0) = 0.5: endTan(1) = 0.5: endTan(2) = 0 points1(0) = points0(4): points1(1) = points0(5): points1(2) = 0 '第2点
points1(3) = R * Sin(th(2)): points1(4) = R * Cos(th(2)): points1(5) = 0 '第3点
points1(6) = Ra * Sin(th(3)): points1(7) = Ra * Cos(th(3)): points1(8) = 0 '第4点 points2(0) = points1(6): points2(1) = points1(7) '第4点
points2(2) = points1(6): points2(3) = points1(7) + 2.25 * m '第5点
points2(4) = 0: points2(5) = points2(3) '第6点 '当基圆小于根圆，调整第1，第2点坐标，得到近似值
If Rb < Rf Then
points0(2) = points1(3) * 0.2: points0(3) = points0(1) + 0.25 * m * 0.03 '第1点
points0(4) = points1(3) * 0.7: points0(5) = points0(1) + 0.25 * m * 0.8 '第2点
points1(0) = points0(4): points1(1) = points0(5): points1(2) = 0 '第2点
End If '创建右部线段
Set curves(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(points0) '由0，1，2点组成
curves(0).SetBulge 1, 0.2 '第一点凸度为0.2
Set curves(1) = ThisDrawing.ModelSpace.AddSpline(points1, startTan, endTan) '由2，3，4点组成
Set curves(2) = ThisDrawing.ModelSpace.AddLightWeightPolyline(points2) '由4，5，6点组成 '镜像右部线段，得到左部线段
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 curves(3) = curves(2).Mirror(point1, point2)
Set curves(4) = curves(1).Mirror(point1, point2)
Set curves(5) = curves(0).Mirror(point1, point2) '创建面域
刀具 = ThisDrawing.ModelSpace.AddRegion(curves)
'创建面域
Dim taperAngle As Double
taperAngle = 0
Dim solidObj As AutoCAD.Acad3DSolid
Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolid(刀具(0), B * 1.1, taperAngle)
Dim center(2) As Double
center(0) = 0: center(1) = solidObj.Centroid(1): center(2) = 0
solidObj.Move solidObj.Centroid, center '环形阵列
Dim basePnt(2) As Double
basePnt(0) = 0: basePnt(1) = 0: basePnt(2) = 0#
刀具 = solidObj.ArrayPolar(Z + 1, 2 * Pi, basePnt)
End Sub '齿数、模数改变，其他结构参数根据经验公式改变
Private Sub TextBox1_Change()
Me.TextBox4.Text = CInt(Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) * 0.3) '轴径D4
D4 = Val(Me.TextBox4.Text)
Me.TextBox5.Text = CInt(1.2 * Val(Me.TextBox4.Text)) '齿宽B
Da = Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) + 2 * Val(Me.TextBox2.Text)
Me.TextBox6.Text = Da - 12 * Val(Me.TextBox2.Text) 'D0
Me.TextBox7.Text = 1.6 * D4 'D3
End Sub Private Sub UserForm_Initialize()
Me.Caption = "齿轮结构参数化三维造型"

Me.Label1.Caption = "齿数Z"
Me.Label2.Caption = "模数m"
Me.Label3.Caption = "压力角Af"
Me.Label4.Caption = "轴径D4"
Me.Label5.Caption = "齿宽B"
Me.Label6.Caption = "D0"
Me.Label7.Caption = "D3" '赋初值
Me.TextBox1.Text = 40 '齿数
Me.TextBox2.Text = 6 '模数
Me.TextBox3.Text = 20 '压力角
Me.TextBox4.Text = CInt(Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) * 0.3) '轴径D4
D4 = Val(Me.TextBox4.Text)
Me.TextBox5.Text = CInt(1.2 * Val(Me.TextBox4.Text)) '齿宽B
Da = Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) + 2 * Val(Me.TextBox2.Text)
Me.TextBox6.Text = Da - 12 * Val(Me.TextBox2.Text) 'D0
Me.TextBox7.Text = 1.6 * D4 'D3 Me.CheckBox1.Caption = "画腹板孔"
Me.CheckBox1.Value = True '画腹板孔 Me.CommandButton1.Caption = "绘图"
Me.CommandButton2.Caption = "退出"
End Sub
Function Acos(ByVal x As Double) As Double
Acos = Atn(Sqr(1 - x * x) / x)
End Function
效果如下图：

雪山飞狐_lzh

gzy的 VB.Net书到了？可以分享一下么？

gzy

我等的花儿也谢了！！！搞了我25天才搞来！！！！


当然可以共享啦！！光盘210M，压缩也是21M，放在论坛不大合适吧？


         晚上跟老大讨论一下到FTP怎么样。不行的话我传给你。

yfy2003

谢了!我已经收到你的了!

雪山飞狐_lzh

收到，献花一朵以表谢意

cag

呵呵，能否传一份给我？先谢了！ MinGoldFish@163.com

Michael527

能否给我一份？michael5277@163.com，谢谢！

xlmx-whj

好东西，期待您的下一版。

lihexu998

能不能给我一份

zcjhy

能不能给我传一个         zhoucj@fc18.com