form023.frm

锥齿轮CAD设计

      Height          =   210
      Left            =   3720
      TabIndex        =   29
      Top             =   3480
      Width           =   1815
   End
   Begin VB.Label Label15 
      AutoSize        =   -1  'True
      BackColor       =   &H00FFFFFF&
      BackStyle       =   0  'Transparent
      Caption         =   "o"
      Height          =   180
      Index           =   1
      Left            =   3240
      TabIndex        =   28
      Top             =   2280
      Width           =   90
   End
End
Attribute VB_Name = "Form023"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()

Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""

End Sub

Private Sub Command3_Click()
                                          '小齿轮绘图
acadapp.Documents.Add

Dim cz As Double
Dim cm As Double
Dim ca As Double
Dim cr As Double
Dim crb As Double
Dim cra As Double
Dim crf As Double  '齿数，模数，压力角，分度圆r，基圆r，齿顶圆r，齿底圆r

cz = Text2.Text                   '小齿轮齿数
cm = Text3.Text                   '模数
ca = Text4.Text * 3.1415926 / 180 '压力角
czd = Text1.Text                  '大齿轮齿数

                                  '设置画图比例。

Dim u As Double


If Option6.Value = True Then
u = 1
End If

If Option7.Value = True Then
u = 1 / 2
End If

If Option8.Value = True Then
u = 1 / 5
End If

If Option9.Value = True Then
u = 1 / 10
End If

If Option10.Value = True Then
u = 5
End If

If Option11.Value = True Then
u = 2
End If


'计算出最原始的数据。………………………………………………

cr = u * (cm * cz / 2)                '分度圆半径
crf = u * (cm * cz - 2.5 * cm) / 2    '齿根圆半径
'crb = u * cr * Cos(ca)               '基圆半径
cra = u * (cm * cz + 2 * cm) / 2      '齿顶圆半径


'画图纸。
Dim tzc As Double          '图纸长
Dim tzk As Double          '图纸宽
Dim e As Double


'确定图纸的长与宽。

If Option1.Value = True Then
tzc = 1189
tzg = 841
e = 20
End If

If Option2.Value = True Then
tzc = 841
tzg = 594
e = 20
End If

If Option3.Value = True Then
tzc = 594
tzg = 420
e = 10
End If

If Option4.Value = True Then
tzc = 420
tzg = 297
e = 10
End If

If Option5.Value = True Then
tzc = 297
tzg = 210
e = 10
End If









 '画齿轮剖视图 ''''''''''''''''''''''''''''''''''''''锥齿轮腹板式  da < 500mm

Dim zbjl As Double          '左，右 边距离
Dim ybjl As Double

Dim zxxsp As Double         '中心线左-水平线
Dim zxxy As Double          '中心线右-竖线
Dim ndj As Double           '内倒角

Dim bb As Double             'B
Dim cc As Double            'c
Dim j As Double             'J
Dim r As Double             'R
Dim del1 As Double          '
Dim l As Double             '齿轮宽
Dim d0 As Double            'd0
Dim d1 As Double            'd1
Dim d2 As Double            'd2
Dim d3 As Double            'D3
Dim d4 As Double            'd4轴直径
                            ''''''''''''''''''''角
Dim a1 As Double             '分锥角
Dim aa1 As Double            '顶锥角
Dim af1 As Double            '根锥角
Dim setf As Double           '齿根角

Dim zfbk As Double           '左腹板宽
Dim yfbk As Double           '右腹板宽
Dim zb As Double             '左边伸出量



d = Text1.Text
zxxsp = tzg / 2 + 20
zxxy = tzc - 2 * e - cra - 40            '3 * tkc / 8
dj = 2
ndj = 2
ybjl = zxxy
r = (cm / 2) * Sqr(cz ^ 2 + czd ^ 2)
bb = Int(r / 3)              ''''''''b<=(r/3)取整
cc = 0.25 * bb
del1 = 0.15 * bb
da = 2 * cra
d4 = d
d3 = 1.6 * d4
d0 = da - 12 * cm
d1 = (d0 + d3) / 2
d2 = 0.3 * (d0 - d3)
               '钢材

'setf = arcTan(1.2 * cm / r)
setf = 5
'a1 = arcTan(cz / czd)
'aa1 = a1 + setf
'af1 = a1 - setf
a1 = 60
aa1 = 63
af1 = 55




l = 1.2 * d4


''''''''''''''''''
zfbk = 10
yfbk = 20
zb = 5


''''''''''''''''''''

If Option5.Value Then
zbjl = 60
End If

If Option4.Value Then
zbjl = 100
End If

If Option3.Value Then
zbjl = 120
End If

If Option2.Value Then
zbjl = 150
End If

If Option1.Value Then
zbjl = 160
End If




Dim z12 As AcadLine
Dim startpointz12(0 To 2) As Double
Dim endpointz12(0 To 2) As Double
startpointz12(0) = zbjl#: startpointz12(1) = zxxsp - Sin(aa1) * bb + cra#: startpointz12(2) = 0#
endpointz12(0) = zbjl + Cos(aa1) * bb#: endpointz12(1) = zxxsp + cra#: startpointz12(2) = 0#
Set z12 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz12, endpointz12)

Dim z24 As AcadLine
Dim startpointz24(0 To 2) As Double
Dim endpointz24(0 To 2) As Double
startpointz24(0) = zbjl + Cos(aa1) * bb#: startpointz24(1) = zxxsp + cra#: startpointz24(2) = 0#
endpointz24(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: endpointz24(1) = zxxsp + crf - Cos(a1) * del1#: endpointz24(2) = 0#
Set z24 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz24, endpointz24)

Dim z47 As AcadLine
Dim startpointz47(0 To 2) As Double
Dim endpointz47(0 To 2) As Double
startpointz47(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: startpointz47(1) = zxxsp + crf - Cos(a1) * del1#: startpointz47(2) = 0#
endpointz47(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: endpointz47(1) = zxxsp + d3 / 2#: endpointz47(2) = 0#
Set z47 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz47, endpointz47)

Dim z45 As AcadLine
Dim startpointz45(0 To 1) As Double
Dim endpointz45(0 To 1) As Double
startpointz45(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: startpointz45(1) = zxxsp + crf - Cos(a1) * del1#: startpointz45(1) = 0#
endpointz45(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: endpointz45(1) = zxxsp + crf - Cos(a1) * del1 - Tan(af1) * yfbk#: startpointz45(1) = 0#
Set z45 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz45, endpointz45)

Dim z56 As AcadLine
Dim startpointz56(0 To 1) As Double
Dim endpointz56(0 To 1) As Double
startpointz56(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: startpointz56(1) = zxxsp + crf - Cos(a1) * del1 - Tan(af1) * yfbk#: startpointz56(1) = 0#
endpointz56(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: endpointz56(1) = zxxsp + d3 / 2#: startpointz56(1) = 0#
Set z56 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz56, endpointz56)

Dim z68 As AcadLine
Dim startpointz68(0 To 1) As Double
Dim endpointz68(0 To 1) As Double
startpointz68(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: startpointz68(1) = zxxsp + d3 / 2#: startpointz68(1) = 0#
endpointz68(0) = zbjl + l#: endpointz68(1) = zxxsp + d3 / 2#: startpointz68(1) = 0#
Set z68 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz68, endpointz68)

Dim z89 As AcadLine
Dim startpointz89(0 To 1) As Double
Dim endpointz89(0 To 1) As Double
startpointz89(0) = zbjl + l#: startpointz89(1) = zxxsp + d3 / 2#: startpointz89(1) = 0#
endpointz89(0) = zbjl + l#: endpointz89(1) = zxxsp - d3 / 2#: startpointz89(1) = 0#
Set z89 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz89, endpointz89)

Dim z911 As AcadLine
Dim startpointz911(0 To 1) As Double
Dim endpointz911(0 To 1) As Double
startpointz911(0) = zbjl + l#: startpointz911(1) = zxxsp - d3 / 2#: startpointz911(1) = 0#
endpointz911(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: endpointz911(1) = zxxsp - d3 / 2#: startpointz911(1) = 0#
Set z911 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz911, endpointz911)

Dim z1112 As AcadLine
Dim startpointz1112(0 To 1) As Double
Dim endpointz1112(0 To 1) As Double
startpointz1112(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: startpointz1112(1) = zxxsp - d3 / 2#: startpointz1112(1) = 0#
endpointz1112(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: endpointz1112(1) = zxxsp - crf + Cos(a1) * del1 + Tan(af1) * yfbk#: startpointz1112(1) = 0#
Set z1112 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1112, endpointz1112)

Dim z1213 As AcadLine
Dim startpointz1213(0 To 1) As Double
Dim endpointz1213(0 To 1) As Double
startpointz1213(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm - yfbk#: startpointz1213(1) = zxxsp - crf + Cos(a1) * del1 + Tan(af1) * yfbk#: startpointz1213(1) = 0#
endpointz1213(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: endpointz1213(1) = zxxsp - crf + Cos(a1) * del1#: startpointz1213(1) = 0#
Set z1213 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1213, endpointz1213)

Dim z1013 As AcadLine
Dim startpointz1013(0 To 1) As Double
Dim endpointz1013(0 To 1) As Double
startpointz1013(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: startpointz1013(1) = zxxsp - d3 / 2#: startpointz1013(1) = 0#
endpointz1013(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: endpointz1013(1) = zxxsp - crf + Cos(a1) * del1#: startpointz1013(1) = 0#
Set z1013 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1013, endpointz1013)

Dim z1315 As AcadLine
Dim startpointz1315(0 To 1) As Double
Dim endpointz1315(0 To 1) As Double
startpointz1315(0) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm#: startpointz1315(1) = zxxsp - crf + Cos(a1) * del1#: startpointz1315(1) = 0#
endpointz1315(0) = zbjl + Cos(aa1) * bb#: endpointz1315(1) = zxxsp - cra#: startpointz1315(1) = 0#
Set z1315 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1315, endpointz1315)

Dim z1516 As AcadLine
Dim startpointz1516(0 To 1) As Double
Dim endpointz1516(0 To 1) As Double
startpointz1516(0) = zbjl + Cos(aa1) * bb#: startpointz1516(1) = zxxsp - cra#: startpointz1516(1) = 0#
endpointz1516(0) = zbjl#: endpointz1516(1) = zxxsp + Sin(aa1) * bb - cra#: startpointz1516(1) = 0#
Set z1516 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1516, endpointz1516)

Dim z1617 As AcadLine
Dim startpointz1617(0 To 1) As Double
Dim endpointz1617(0 To 1) As Double
startpointz1617(0) = zbjl#: startpointz1617(1) = zxxsp - Sin(aa1) * bb + cra#: startpointz1617(1) = 0#
endpointz1617(0) = zbjl + zfbk#: endpointz1617(1) = zxxsp - crf + Sin(af1) * bb#: startpointz1617(1) = 0#
Set z1617 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1617, endpointz1617)

Dim z1619 As AcadLine
Dim startpointz1619(0 To 1) As Double
Dim endpointz1619(0 To 1) As Double
startpointz1619(0) = zbjl#: startpointz1619(1) = zxxsp - Sin(aa1) * bb + cra#: startpointz1619(1) = 0#
endpointz1619(0) = zbjl#: endpointz1619(1) = zxxsp - d3 / 2#: startpointz1619(1) = 0#
Set z1619 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1619, endpointz1619)

Dim z1718 As AcadLine
Dim startpointz1718(0 To 1) As Double
Dim endpointz1718(0 To 1) As Double
startpointz1718(0) = zbjl + zfbk#: startpointz1718(1) = zxxsp - crf + Sin(af1) * bb#: startpointz1718(1) = 0#
endpointz1718(0) = zbjl + zfbk#: endpointz1718(1) = zxxsp - d3 / 2#: startpointz1718(1) = 0#
Set z1718 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1718, endpointz1718)

Dim z2018 As AcadLine
Dim startpointz2018(0 To 1) As Double
Dim endpointz2018(0 To 1) As Double
startpointz2018(0) = zbjl - zb#: startpointz2018(1) = zxxsp - d3 / 2#: startpointz2018(1) = 0#
endpointz2018(0) = zbjl + zfbk#: endpointz2018(1) = zxxsp - d3 / 2#: startpointz2018(1) = 0#
Set z2018 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz2018, endpointz2018)

Dim z2021 As AcadLine
Dim startpointz2021(0 To 1) As Double
Dim endpointz2021(0 To 1) As Double
startpointz2021(0) = zbjl - zb#: startpointz2021(1) = zxxsp - d3 / 2#: startpointz2021(1) = 0#
endpointz2021(0) = zbjl - zb#: endpointz2021(1) = zxxsp + d3 / 2#: startpointz2021(1) = 0#
Set z2021 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz2021, endpointz2021)

Dim z2321 As AcadLine
Dim startpointz2321(0 To 1) As Double
Dim endpointz2321(0 To 1) As Double
startpointz2321(0) = zbjl + zfbk#: startpointz2321(1) = zxxsp + d3 / 2#: startpointz2321(1) = 0#
endpointz2321(0) = zbjl - zb#: endpointz2321(1) = zxxsp + d3 / 2#: startpointz2321(1) = 0#
Set z2321 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz2321, endpointz2321)

Dim z2324 As AcadLine
Dim startpointz2324(0 To 1) As Double
Dim endpointz2324(0 To 1) As Double
startpointz2324(0) = zbjl + zfbk#: startpointz2324(1) = zxxsp + d3 / 2#: startpointz2324(1) = 0#
endpointz2324(0) = zbjl + zfbk#: endpointz2324(1) = zxxsp + crf - Sin(af1) * bb#: startpointz2324(1) = 0#
Set z2324 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz2324, endpointz2324)

Dim z124 As AcadLine
Dim startpointz124(0 To 1) As Double
Dim endpointz124(0 To 1) As Double
startpointz124(0) = zbjl#: startpointz124(1) = zxxsp - Sin(aa1) * bb + cra#: startpointz124(1) = 0#
endpointz124(0) = zbjl + zfbk#: endpointz124(1) = zxxsp + crf - Sin(af1) * bb#: startpointz124(1) = 0#
Set z124 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz124, endpointz124)

Dim z122 As AcadLine
Dim startpointz122(0 To 1) As Double
Dim endpointz122(0 To 1) As Double
startpointz122(0) = zbjl#: startpointz122(1) = zxxsp - Sin(aa1) * bb + cra#: startpointz122(1) = 0#
endpointz122(0) = zbjl#: endpointz122(1) = zxxsp + d3 / 2#: startpointz122(1) = 0#
Set z122 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz122, endpointz122)

Dim z324 As AcadLine
Dim startpointz324(0 To 1) As Double
Dim endpointz324(0 To 1) As Double
startpointz324(0) = zbjl + bb * Cos(aa1) + 2.2 * Tan(a1) * cm#: startpointz324(1) = zxxsp + crf#: startpointz324(1) = 0#
endpointz324(0) = zbjl + zfbk#: endpointz324(1) = zxxsp + crf - Sin(af1) * bb#: startpointz324(1) = 0#
Set z324 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz324, endpointz324)

Dim z1417 As AcadLine
Dim startpointz1417(0 To 1) As Double
Dim endpointz1417(0 To 1) As Double
startpointz1417(0) = zbjl - bb * Cos(aa1) - 2.2 * Tan(a1) * cm#: startpointz1417(1) = zxxsp - crf#: startpointz1417(1) = 0#
endpointz1417(0) = zbjl - zfbk#: endpointz1417(1) = zxxsp - crf + Sin(af1) * bb#: startpointz1417(1) = 0#
Set z1417 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointz1417, endpointz1417)









End Sub

Private Sub Command4_Click()
                                           '退出界面，退出AutoCAD，释放内存。
Unload Me
Form1.Show
acadapp.Quit
Set acadapp = Nothing

End Sub

Private Sub Command5_Click()
Text10.Text = "1、调质处理230～250HBS;" & vbCrLf & "2、倒角2×45" & "%%d。"
End Sub

Private Sub Command6_Click()
Unload Me
Form021.Show
End Sub

Private Sub Form_Load()

'链接AutoCAD。

On Error Resume Next
Set acadapp = GetObject(, "autocad.application")
If Err Then
    Err.Clear
    Set acadapp = CreateObject("autocad.application")
    If Err Then
       MsgBox ("不能运行AutoCAD，请检查是否已安装AutoCAD！")
       Exit Sub
    End If
 End If
 acadapp.Visible = True

'给TEXT赋初值。


Text5.Text = "陈日勇"
Text6.Text = "陈日勇"
Text9.Text = "05.03.26"
Text8.Text = "锻钢"
Text7.Text = "方  芳"
End Sub