📄 form1.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "标准直齿轮"
ClientHeight = 5070
ClientLeft = 60
ClientTop = 345
ClientWidth = 3015
LinkTopic = "Form1"
ScaleHeight = 5070
ScaleWidth = 3015
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text7
Height = 285
Left = 2040
TabIndex = 12
Text = "34"
Top = 3720
Width = 855
End
Begin VB.TextBox Text6
Height = 285
Left = 2040
TabIndex = 11
Text = "8"
Top = 3360
Width = 855
End
Begin VB.TextBox Text5
Height = 285
Left = 2040
TabIndex = 10
Text = "15"
Top = 3000
Width = 855
End
Begin VB.TextBox Text4
Height = 285
Left = 840
TabIndex = 9
Text = "30"
Top = 4080
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "取消"
Height = 375
Left = 1800
TabIndex = 7
Top = 4560
Width = 855
End
Begin VB.CommandButton Command1
Caption = "确定"
Height = 375
Left = 360
TabIndex = 6
Top = 4560
Width = 855
End
Begin VB.TextBox Text3
Height = 285
Left = 840
TabIndex = 5
Text = "20"
Top = 3720
Width = 735
End
Begin VB.TextBox Text2
Height = 285
Left = 840
TabIndex = 4
Text = "3"
Top = 3360
Width = 735
End
Begin VB.TextBox Text1
Height = 270
Left = 840
TabIndex = 3
Text = "20"
Top = 3000
Width = 735
End
Begin VB.PictureBox Picture1
Height = 2775
Left = 120
Picture = "Form1.frx":0000
ScaleHeight = 2715
ScaleWidth = 2715
TabIndex = 0
Top = 120
Width = 2775
End
Begin VB.Label Label1
Caption = "压力角a"
Height = 255
Index = 1
Left = 120
TabIndex = 16
Top = 3720
Width = 735
End
Begin VB.Label Label5
Caption = "H:"
Height = 255
Left = 1800
TabIndex = 15
Top = 3720
Width = 255
End
Begin VB.Label Label4
Caption = "L:"
Height = 255
Left = 1800
TabIndex = 14
Top = 3360
Width = 135
End
Begin VB.Label Label3
Caption = "r:"
Height = 255
Left = 1800
TabIndex = 13
Top = 3000
Width = 255
End
Begin VB.Label Label2
Caption = "齿 高"
Height = 255
Left = 120
TabIndex = 8
Top = 4080
Width = 615
End
Begin VB.Label Label1
Caption = "模 数m"
Height = 255
Index = 2
Left = 120
TabIndex = 2
Top = 3360
Width = 615
End
Begin VB.Label Label1
Caption = "齿 数z"
Height = 255
Index = 0
Left = 120
TabIndex = 1
Top = 3000
Width = 615
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long
Dim Annotation As Object
Dim Gtol As Object
Dim DatumTag As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Private Sub Command1_Click()
Dim z As Integer '定义齿数z
Dim m As Variant '定义模数m
Dim a, Q, Q0, Q1(91), Q2 As Double '定义压力角a
Dim t As Double '定义t为渐开线所走的角度
Dim R, Rb, Ra, Rf As Variant 'R为分度圆半径，Rb为基圆半径,Ra为齿顶圆半径,Rf为齿根圆半径
Const pi As Single = 3.14159265359
Dim ha, c As Double 'ha为齿顶高系数，c为顶隙系数
Dim xt, yt, zt, xt0(91), yt0(91), zt0(91), xt1(91), yt1(91), zt1(91), xt2(90), yt2(90), zt2(90) As Variant
Dim xr(90), yr(90) As Variant
Dim L(91), L1, L2, L3, Q3, Q4, Q5 As Variant
Dim i, n As Integer
Dim x, y, x1, y1, x2, y2 As Variant
Dim B, Rr, Ll, H As Variant
Dim afa, xa, ya, za, qa As Variant
z = Val(Text1.Text)
m = Val(Text2.Text)
a = Val(Text3.Text)
B = Val(Text4.Text)
Rr = Val(Text5.Text) 'r
Ll = Val(Text6.Text) 'l
H = Val(Text7.Text) 'H
Set swApp = CreateObject("sldworks.application")
Set Part = swApp.newpart()
Set Part = swApp.ActiveDoc
If m >= 1 Then
ha = 1
c = 0.25
Else
ha = 1
c = 0.35
End If
R = z * m / 2
Rb = R * Cos(a * pi / 180)
Ra = R + ha * m
Rf = R - (ha + c) * m '注意：如果齿数z＞42时，Rb<Rf。
Q = ((1 / (Cos(a * pi / 180)) ^ 2) - 1) ^ (1 / 2)
xt = Rb * (Cos(Q) + Q * Sin(Q)) '渐开线与分度圆的交点
yt = Rb * (Sin(Q) - Q * Cos(Q))
Q0 = Atn(yt / xt)
'Part.CreateCircle 0, 0, 0, Ra / 1000, 0, 0 '画齿顶圆
'Part.CreateCircle 0, 0, 0, 0, Rf/1000, 0 '画齿根圆
'Part.CreateCircle 0, 0, 0, Rb / 1000, 0, 0 '画基圆
'Part.CreateCircle 0, 0, 0, 0, R/1000, 0 '分度圆
n = 0
For t = 0 To 80 Step 1 '绘制一段渐开线(角度是0到20)
xt0(t) = Rb * (Cos(t * pi / 180) + (t * pi / 180) * Sin(t * pi / 180))
yt0(t) = Rb * (Sin(t * pi / 180) - (t * pi / 180) * Cos(t * pi / 180))
zt0(t) = 0
If (xt0(t) ^ 2 + yt0(t) ^ 2) ^ (1 / 2) <= Ra Then
n = n + 1
xt1(t) = xt0(t)
yt1(t) = yt0(t)
zt1(t) = 0
L(t) = (xt1(t) ^ 2 + yt1(t) ^ 2) ^ (1 / 2) '点(xt1,yt1,zt1)到圆心的距离
Q1(t) = Atn(yt1(t) / xt1(t))
xr(t) = xt1(t)
yr(t) = yt1(t)
End If
x1 = xt1(n - 1)
y1 = yt1(n - 1)
Next t
For t = 0 To n - 1 Step 1
xt0(n - t - 1) = L(n - t - 1) * Cos((pi / z) - Q1(n - t - 1) + 2 * Q0) '镜向后渐开线的坐标(xt2,yt2,zt2)
yt0(n - t - 1) = L(n - t - 1) * Sin((pi / z) - Q1(n - t - 1) + 2 * Q0)
zt0(n - t - 1) = 0
xt2(t) = xt0(n - t - 1) '镜向后渐开线的坐标(xt2,yt2,zt2)
yt2(t) = yt0(n - t - 1)
zt2(t) = 0
Next t
x2 = xt2(n - 1)
y2 = yt2(n - 1)
' Close #2
Q2 = 2 * pi / z '旋转的角度
If z <= 40 Then
Part.InsertCurveFileBegin
For i = 0 To z - 1 Step 1
Part.InsertCurveFilePoint Rf * Cos(Q2 * i) / 1000, Rf * Sin(Q2 * i) / 1000, 0 '齿根圆到基圆间的直线部分
Part.InsertCurveFilePoint (Rb + Rf) * Cos(Q2 * i) / 2000, (Rb + Rf) * Sin(Q2 * i) / 2000, 0
For t = 0 To n - 1 Step 1
L1 = (xt1(t) ^ 2 + yt1(t) ^ 2) ^ (1 / 2)
Q3 = Atn(yt1(t) / xt1(t))
Part.InsertCurveFilePoint L1 * Cos(Q3 + Q2 * i) / 1000, L1 * Sin(Q3 + Q2 * i) / 1000, zt1(t) / 1000
Next t
Part.InsertCurveFilePoint Ra * Cos(pi / (2 * z) + Q0 + Q2 * i) / 1000, Ra * Sin(pi / (2 * z) + Q0 + Q2 * i) / 1000, 0 '齿顶圆处的直线
For t = 0 To n - 1 Step 1
L2 = (xt2(t) ^ 2 + yt2(t) ^ 2) ^ (1 / 2)
Q4 = Atn(yt2(t) / xt2(t))
Part.InsertCurveFilePoint L2 * Cos(Q4 + Q2 * i) / 1000, L2 * Sin(Q4 + Q2 * i) / 1000, zt2(t) / 1000
Next t
Part.InsertCurveFilePoint (Rf + Rb) * Cos(pi / z + 2 * Q0 + Q2 * i) / 2000, (Rf + Rb) * Sin(pi / z + 2 * Q0 + Q2 * i) / 2000, 0
Part.InsertCurveFilePoint Rf * Cos(pi / z + 2 * Q0 + Q2 * i) / 1000, Rf * Sin(pi / z + 2 * Q0 + Q2 * i) / 1000, 0 '齿根圆到基圆间的直线部分
Part.InsertCurveFilePoint (Rf - 0.5) * Cos(3 * pi / (2 * z) + Q0 + Q2 * i) / 1000, (Rf - 0.5) * Sin(3 * pi / (2 * z) + Q0 + Q2 * i) / 1000, 0
Next i
Part.InsertCurveFilePoint Rf * Cos(Q2 * i) / 1000, Rf * Sin(Q2 * i) / 1000, 0
Part.InsertCurveFileEnd
Else
afa = ((Rf / (R * Cos(a * pi / 180))) ^ 2 - 1) ^ (1 / 2) '当Z>42时，齿根圆与渐开线的交点与X轴的夹角。
xa = Rb * (Cos(afa) + afa * Sin(afa)) '渐开线与分度圆的交点
ya = Rb * (Sin(afa) - afa * Cos(afa))
qa = Atn(ya / xa)
Part.InsertCurveFileBegin
Part.InsertCurveFilePoint Rf * Cos(qa) / 1000, Rf * Sin(qa) / 1000, 0 '齿根圆到基圆间的直线部分
For i = 0 To z - 1 Step 1
For t = 0 To n - 1 Step 1
L1 = (xt1(t) ^ 2 + yt1(t) ^ 2) ^ (1 / 2)
Q3 = Atn(yt1(t) / xt1(t))
If L1 >= Rf Then
Part.InsertCurveFilePoint L1 * Cos(Q3 + Q2 * i) / 1000, L1 * Sin(Q3 + Q2 * i) / 1000, zt1(t) / 1000
End If
Next t
Part.InsertCurveFilePoint Ra * Cos(pi / (2 * z) + Q0 + Q2 * i) / 1000, Ra * Sin(pi / (2 * z) + Q0 + Q2 * i) / 1000, 0 '齿顶圆处的直线
For t = 0 To n - 1 Step 1
L2 = (xt2(t) ^ 2 + yt2(t) ^ 2) ^ (1 / 2)
Q4 = Atn(yt2(t) / xt2(t))
If L2 >= Rf Then
Part.InsertCurveFilePoint L2 * Cos(Q4 + Q2 * i) / 1000, L2 * Sin(Q4 + Q2 * i) / 1000, zt2(t) / 1000
End If
Next t
Part.InsertCurveFilePoint (Rf - 0.5) * Cos(3 * pi / (2 * z) + Q0 + Q2 * i) / 1000, (Rf - 0.5) * Sin(3 * pi / (2 * z) + Q0 + Q2 * i) / 1000, 0
Next i
Part.InsertCurveFilePoint Rf * Cos(qa) / 1000, Rf * Sin(qa) / 1000, 0
Part.InsertCurveFileEnd
End If
'拉伸
boolstatus = Part.Extension.SelectByID("前视", "PLANE", 0, 0, 0, False, 0, Nothing)
Part.InsertSketch2 True
boolstatus = Part.Extension.SelectByID("", "EDGE", Ra * Cos(pi / (2 * z) + Q0) / 1000, Ra * Sin(pi / (2 * z) + Q0) / 1000, 0, False, 0, Nothing)
'其中 坐标(Ra * Cos(pi / (2 * z) + Q0 ) / 1000, Ra * Sin(pi / (2 * z) + Q0 ) / 1000, 0)为选择曲线上的一点坐标。
Part.SketchUseEdge
Part.ClearSelection
boolstatus = Part.Extension.SelectByID("曲线1", "REFERENCECURVES", 0, 0, 0, False, 0, Nothing)
Part.BlankRefGeom
Part.InsertSketch2 True
Part.ClearSelection
boolstatus = Part.Extension.SelectByID("草图1", "SKETCH", 0, 0, 0, False, 0, Nothing)
Part.FeatureManager.FeatureExtrusion True, False, False, 0, 0, B / 1000, 0.01, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, 1, 1, 1
Part.SelectionManager.EnableContourSelection = 0
Part.ShowNamedView2 "*等轴测", 7
Part.ViewZoomtofit2
'齿轮轴孔
boolstatus = Part.Extension.SelectByID("前视", "PLANE", 0, 0, 0, False, 0, Nothing)
Part.InsertSketch2 True
Part.CreateArcVB 0, 0, 0, -Ll / 2000, ((Rr * Rr - (Ll * Ll) / 4) ^ (1 / 2)) / 1000, 0, Ll / 2000, ((Rr * Rr - (Ll * Ll) / 4) ^ (1 / 2)) / 1000, 0, 1
Part.SetPickMode
Part.ClearSelection
Part.createline2 Ll / 2000, ((Rr * Rr - (Ll * Ll) / 4) ^ (1 / 2)) / 1000, 0, Ll / 2000, (H - Rr) / 1000, 0
Part.createline2 Ll / 2000, (H - Rr) / 1000, 0, -Ll / 2000, (H - Rr) / 1000, 0
Part.createline2 -Ll / 2000, (H - Rr) / 1000, 0, -Ll / 2000, ((Rr * Rr - (Ll * Ll) / 4) ^ (1 / 2)) / 1000, 0
Part.ClearSelection
Part.InsertSketch2 True
boolstatus = Part.Extension.SelectByID("草图2", "SKETCH", 0, 0, 0, False, 0, Nothing)
Part.ClearSelection
boolstatus = Part.Extension.SelectByID("草图2", "SKETCH", 0, 0, 0, False, 0, Nothing)
Part.FeatureManager.FeatureCut False, False, False, 0, 0, B / 1000, B / 1000, False, False, False, False, 0.01745329251994, 0.01745329251994, False, False, False, False, 0, 1, 1
Part.SelectionManager.EnableContourSelection = 0
Unload Me
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -