form024.frm

锥齿轮CAD设计

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)

                       ''''''''四小圆
Dim xyzx1 As AcadLine
Dim startpointxyzx1(0 To 1) As Double
Dim endpointxyzx1(0 To 1) As Double
startpointxyzx1(0) = zbjl + zfbk#: startpointxyzx1(1) = zxxsp + d1 / 2 + d2 / 2#: startpointxyzx1(1) = 0#
endpointxyzx1(0) = zbjl + zfbk + cc#: endpointxyzx1(1) = zxxsp + d1 / 2 + d2 / 2#: startpointxyzx1(1) = 0#
Set xyzx1 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointxyzx1, endpointxyzx1)

Dim xyzx2 As AcadLine
Dim startpointxyzx2(0 To 1) As Double
Dim endpointxyzx2(0 To 1) As Double
startpointxyzx2(0) = zbjl + zfbk#: startpointxyzx2(1) = zxxsp + d1 / 2 - d2 / 2#: startpointxyzx2(1) = 0#
endpointxyzx2(0) = zbjl + zfbk + cc#: endpointxyzx2(1) = zxxsp + d1 / 2 - d2 / 2#: startpointxyzx2(1) = 0#
Set xyzx2 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointxyzx2, endpointxyzx2)

Dim xyzx3 As AcadLine
Dim startpointxyzx3(0 To 1) As Double
Dim endpointxyzx3(0 To 1) As Double
startpointxyzx3(0) = zbjl + zfbk#: startpointxyzx3(1) = zxxsp - d1 / 2 + d2 / 2#: startpointxyzx3(1) = 0#
endpointxyzx3(0) = zbjl + zfbk + cc#: endpointxyzx3(1) = zxxsp - d1 / 2 + d2 / 2#: startpointxyzx3(1) = 0#
Set xyzx3 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointxyzx3, endpointxyzx3)

Dim xyzx4 As AcadLine
Dim startpointxyzx4(0 To 1) As Double
Dim endpointxyzx4(0 To 1) As Double
startpointxyzx4(0) = zbjl + zfbk#: startpointxyzx4(1) = zxxsp - d1 / 2 - d2 / 2#: startpointxyzx4(1) = 0#
endpointxyzx4(0) = zbjl + zfbk + cc#: endpointxyzx4(1) = zxxsp - d1 / 2 - d2 / 2#: startpointxyzx4(1) = 0#
Set xyzx4 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointxyzx4, endpointxyzx4)




'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''填充 上上
Dim hatchobj1 As AcadHatch

Dim patternname As String
Dim patterntype As Long
Dim bassociativity As Boolean
''定义填充
patterntype = 0
patternname = "ANSI31"
bassociativity = True

Set hatchobj1 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)

Dim plineobj1 As AcadLWPolyline
Dim points91(0 To 13) As Double

points91(0) = zbjl + zfbk: points91(1) = zxxsp + crf - Sin(af1) * bb           '24
points91(2) = zbjl + bb * Cos(aa1) + 2.2 * Tan(a1) * cm: points91(3) = zxxsp + crf          '3
points91(4) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm: points91(5) = zxxsp + crf - Cos(a1) * del1          '4
points91(6) = zbjl + zfbk + cc: points91(7) = zxxsp + crf - Cos(a1) * del1 - Tan(af1) * yfbk        '5
points91(8) = zbjl + zfbk + cc: points91(9) = zxxsp + d1 / 2 + d2 / 2        '
points91(10) = zbjl + zfbk: points91(11) = zxxsp + d1 / 2 + d2 / 2          '
points91(12) = zbjl + zfbk: points91(13) = zxxsp + crf - Sin(af1) * bb          '24
'points91(14) = zbjl + wide - fbsd: points91(15) = zxxsp + jl - fbnj / 2          '


Set plineobj1 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points91)
Dim outerloop1(0 To 0) As AcadEntity
Set outerloop1(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points91)

hatchobj1.AppendOuterLoop (outerloop1)
hatchobj1.Evaluate

 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''下上
Dim hatchobj2 As AcadHatch

patterntype = 0
patternname = "ANSI31"
bassociativity = True

Set hatchobj2 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)

Dim plineobj2 As AcadLWPolyline
Dim points92(0 To 17) As Double

points92(0) = zbjl: points92(1) = zxxsp + jl + fbkd / 2 + ndj         '21
points92(2) = zbjl: points92(3) = zxxsp + crf         '23
points92(4) = zbjl + wide: points92(5) = zxxsp + crf         '
points92(6) = zbjl + wide: points92(7) = zxxsp + jl + fbkd / 2 + ndj         '
points92(8) = zbjl + wide - ndj: points92(9) = zxxsp + jl + fbkd / 2         '6
points92(10) = zbjl + wide - fbsd: points92(11) = zxxsp + jl + fbkd / 2         '8
points92(12) = zbjl + wide - fbsd: points92(13) = zxxsp + jl + fbnj / 2         '
points92(14) = zbjl + fbsd: points92(15) = zxxsp + jl + fbnj / 2         '
points92(16) = zbjl + fbsd: points92(17) = zxxsp + jl + fbkd / 2         '



Set plineobj2 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points92)
Dim outerloop2(0 To 0) As AcadEntity
Set outerloop2(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points92)

hatchobj2.AppendOuterLoop (outerloop2)
hatchobj2.Evaluate

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''填充 下上
Dim hatchobj3 As AcadHatch

patterntype = 0
patternname = "ANSI31"
bassociativity = True

Set hatchobj3 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)

Dim plineobj3 As AcadLWPolyline
Dim points93(0 To 21) As Double

points93(0) = zbjl - zb: points93(1) = zxxsp - d4 / 2 - ndj        'q
points93(2) = zbjl - zb: points93(3) = zxxsp - d3 / 2        '20
points93(4) = zbjl + zfbk: points93(5) = zxxsp - d3 / 2      '18
points93(6) = zbjl + zfbk: points93(7) = zxxsp - d1 / 2 + d2 / 2      '
points93(8) = zbjl + zfbk + cc: points93(9) = zxxsp - d1 / 2 + d2 / 2      '
points93(10) = zbjl + zfbk + cc: points93(11) = zxxsp - d3 / 2     '11
points93(12) = zbjl + l - zb: points93(13) = zxxsp - d3 / 2    '9
points93(14) = zbjl + l - zb: points93(15) = zxxsp - d4 / 2 - ndj   'n
points93(16) = zbjl + l - zb - ndj: points93(17) = zxxsp - d4 / 2      'o
points93(18) = zbjl - zb + ndj: points93(19) = zxxsp - d4 / 2    'p
points93(20) = zbjl - zb: points93(21) = zxxsp - d4 / 2 - ndj        'q

Set plineobj3 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points93)
Dim outerloop3(0 To 0) As AcadEntity
Set outerloop3(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points93)

hatchobj3.AppendOuterLoop (outerloop3)
hatchobj3.Evaluate

 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''下下
Dim hatchobj4 As AcadHatch

patterntype = 0
patternname = "ANSI31"
bassociativity = True

Set hatchobj4 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)

Dim plineobj4 As AcadLWPolyline
Dim points94(0 To 13) As Double

points94(0) = zbjl + zfbk: points94(1) = zxxsp - crf + Sin(af1) * bb           '24
points94(2) = zbjl + bb * Cos(aa1) + 2.2 * Tan(a1) * cm: points94(3) = zxxsp - crf          '3
points94(4) = zbjl + Cos(aa1) * bb + 2.2 * Tan(a1) * cm: points94(5) = zxxsp - crf + Cos(a1) * del1          '4
points94(6) = zbjl + zfbk + cc: points94(7) = zxxsp - crf + Cos(a1) * del1 + Tan(af1) * yfbk        '5
points94(8) = zbjl + zfbk + cc: points94(9) = zxxsp - d1 / 2 - d2 / 2        '
points94(10) = zbjl + zfbk: points94(11) = zxxsp - d1 / 2 - d2 / 2          '
points94(12) = zbjl + zfbk: points94(13) = zxxsp - crf + Sin(af1) * bb          '24
'points94(14) = zbjl + wide - fbsd: points94(15) = zxxsp + jl - fbnj / 2          '

Set plineobj4 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points94)
Dim outerloop4(0 To 0) As AcadEntity
Set outerloop4(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points94)

hatchobj4.AppendOuterLoop (outerloop4)
hatchobj4.Evaluate













'画中心线。
''定义线型（中心线）
acadapp.ActiveDocument.Linetypes.Load "center", "D:\Program Files\AutoCAD 2002\Support\acadiso.lin"

acadapp.ActiveDocument.ActiveLinetype = acadapp.ActiveDocument.Linetypes.Item("center")

Dim fdy1j As AcadCircle

Dim zxx0j As AcadLine                        '画左边的一段中心线
Dim startpoint001j(0 To 2) As Double
Dim endpoint001j(0 To 2) As Double
startpoint001j(0) = zbjl - 10#: startpoint001j(1) = zxxsp#: startpoint001j(2) = 0#
endpoint001j(0) = zbjl + l + 10#: endpoint001j(1) = zxxsp#: endpoint001j(2) = 0#
Set zxx0j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint001j, endpoint001j)


Dim fdy6j As AcadCircle

Dim zxx6j As AcadLine                        '画右边的一段中心线。---
Dim startpoint006j(0 To 2) As Double
Dim endpoint006j(0 To 2) As Double
startpoint006j(0) = ybjl - cra - 20#: startpoint006j(1) = zxxsp#: startpoint006j(2) = 0#
endpoint006j(0) = ybjl + cra + 20#: endpoint006j(1) = zxxsp#: endpoint006j(2) = 0#
Set zxx6j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint006j, endpoint006j)

Dim fdy7j As AcadCircle

Dim zxx7j As AcadLine                        '画右边的一段中心线。|
Dim startpoint007j(0 To 2) As Double
Dim endpoint007j(0 To 2) As Double
startpoint007j(0) = ybjl#: startpoint007j(1) = zxxsp + cra + 20#: startpoint007j(2) = 0#
endpoint007j(0) = ybjl#: endpoint007j(1) = zxxsp - cra - 20#: endpoint007j(2) = 0#
Set zxx7j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint007j, endpoint007j)

Dim fdy As AcadCircle         '分度圆
Dim centerpointfdy(0 To 2) As Double
centerpointfdy(0) = ybjl#: centerpointfdy(1) = zxxsp#: centerpointfdy(2) = 0#:
Set fdy = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointfdy, cr)

fdy.Lineweight = acLnWt30

Dim zky As AcadCircle         '周孔圆
Dim centerpointzky(0 To 2) As Double
centerpointzky(0) = ybjl#: centerpointzky(1) = zxxsp#: centerpointzky(2) = 0#:
Set zky = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointzky, d1 / 2)

zky.Lineweight = acLnWt30





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