form012斜齿轮齿轮轴.frm

锥齿轮CAD设计

Dim ia As AcadLine
Dim startpointia(0 To 2) As Double
Dim endpointia(0 To 2) As Double
startpointia(0) = zbjl#: startpointia(1) = zxxsp + cra - dj#: startpointia(2) = 0#
endpointia(0) = zbjl#: endpointia(1) = zxxsp#: endpointia(2) = 0#
Set ia = acadapp.ActiveDocument.ModelSpace.AddLine(startpointia, endpointia)

Dim hc As AcadLine
Dim startpointhc(0 To 2) As Double
Dim endpointhc(0 To 2) As Double
startpointhc(0) = zbjl + dj#: startpointhc(1) = zxxsp + cra#: startpointhc(2) = 0#
endpointhc(0) = zbjl + dj#: endpointhc(1) = zxxsp - cra#: endpointhc(2) = 0#
Set hc = acadapp.ActiveDocument.ModelSpace.AddLine(startpointhc, endpointhc)

Dim gd As AcadLine
Dim startpointgd(0 To 2) As Double
Dim endpointgd(0 To 2) As Double
startpointgd(0) = zbjl + wide - dj#: startpointgd(1) = zxxsp + cra#: startpointgd(2) = 0#
endpointgd(0) = zbjl + dj + wide - 2 * dj#: endpointgd(1) = zxxsp - cra#: endpointgd(2) = 0#
Set gd = acadapp.ActiveDocument.ModelSpace.AddLine(startpointgd, endpointgd)

Dim jk As AcadLine
Dim startpointjk(0 To 2) As Double
Dim endpointjk(0 To 2) As Double
startpointjk(0) = zbjl - 10#: startpointjk(1) = zxxsp + clzbj#: startpointjk(2) = 0#
endpointjk(0) = zbjl#: endpointjk(1) = zxxsp + clzbj#: endpointjk(2) = 0#
Set jk = acadapp.ActiveDocument.ModelSpace.AddLine(startpointjk, endpointjk)

Dim lm As AcadLine
Dim startpointlm(0 To 2) As Double
Dim endpointlm(0 To 2) As Double
startpointlm(0) = zbjl - 10#: startpointlm(1) = zxxsp - clzbj#: startpointlm(2) = 0#
endpointlm(0) = zbjl#: endpointlm(1) = zxxsp - clzbj#: endpointlm(2) = 0#
Set lm = acadapp.ActiveDocument.ModelSpace.AddLine(startpointlm, endpointlm)

Dim qp As AcadLine
Dim startpointqp(0 To 2) As Double
Dim endpointqp(0 To 2) As Double
startpointqp(0) = zbjl + wide#: startpointqp(1) = zxxsp - clzbj#: startpointqp(2) = 0#
endpointqp(0) = zbjl + wide + 10#: endpointqp(1) = zxxsp - clzbj#: endpointqp(2) = 0#
Set qp = acadapp.ActiveDocument.ModelSpace.AddLine(startpointqp, endpointqp)

Dim no As AcadLine
Dim startpointno(0 To 2) As Double
Dim endpointno(0 To 2) As Double
startpointno(0) = zbjl + wide#: startpointno(1) = zxxsp + clzbj#: startpointno(2) = 0#
endpointno(0) = zbjl + wide + 10#: endpointno(1) = zxxsp + clzbj#: endpointno(2) = 0#
Set no = acadapp.ActiveDocument.ModelSpace.AddLine(startpointno, endpointno)

Dim pq As AcadLine
Dim startpointpq(0 To 2) As Double
Dim endpointpq(0 To 2) As Double
startpointpq(0) = zbjl#: startpointpq(1) = zxxsp + crf#: startpointpq(2) = 0#
endpointpq(0) = zbjl + wide#: endpointpq(1) = zxxsp + crf#: endpointpq(2) = 0#
Set pq = acadapp.ActiveDocument.ModelSpace.AddLine(startpointpq, endpointpq)

Dim rs As AcadLine
Dim startpointrs(0 To 2) As Double
Dim endpointrs(0 To 2) As Double
startpointrs(0) = zbjl#: startpointrs(1) = zxxsp - crf#: startpointrs(2) = 0#
endpointrs(0) = zbjl + wide#: endpointrs(1) = zxxsp - crf#: endpointrs(2) = 0#
Set rs = acadapp.ActiveDocument.ModelSpace.AddLine(startpointrs, endpointrs)



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''右视图

Dim cdy As AcadCircle         '齿顶圆
Dim centerpointcdy(0 To 2) As Double
centerpointcdy(0) = ybjl#: centerpointcdy(1) = zxxsp#: centerpointcdy(2) = 0#:
Set cdy = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointcdy, cra)

cdy.Lineweight = acLnWt30

Dim cgy As AcadCircle         '齿根圆
Dim centerpointcgy(0 To 2) As Double
centerpointcgy(0) = ybjl#: centerpointcgy(1) = zxxsp#: centerpointcgy(2) = 0#:
Set cgy = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointcgy, crf)

cgy.Lineweight = acLnWt30

Dim nk As AcadCircle         '齿轮轴
Dim centerpointnk(0 To 2) As Double
centerpointnk(0) = ybjl#: centerpointnk(1) = zxxsp#: centerpointnk(2) = 0#:
Set nk = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointnk, clzbj)

nk.Lineweight = acLnWt30





'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''标注bz

Dim bz1 As AcadDimAligned             ''''''''''齿顶圆
Dim point11(0 To 2) As Double
Dim point12(0 To 2) As Double
Dim location1(0 To 2) As Double


'定义尺寸标注。
point11(0) = zbjl + wide - dj#: point11(1) = zxxsp + cra#: point11(2) = 0#
point12(0) = zbjl + wide - dj#: point12(1) = zxxsp - cra#: point12(2) = 0#

location1(0) = zbjl + wide - dj + 50#: location1(1) = 0#: location1(2) = 0#

'创建平行尺寸标注对象。
If Option6.Value = True Then
Set bz1 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point11, point12, location1)

Else
''''''''''''''''''''''''''''''''''自己写尺寸@@@@@@@@@@@@@@@
Set bz1 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point11, point12, location1)
Dim zbz1 As Integer
zbz1 = cm * (cz + 2) / 3
bz1.TextOverride = zbz1

End If
                                        '标注公差。
                                        
bz1.DecimalSeparator = "."   '小数点符号。
'公差显示特性。
bz1.ToleranceDisplay = acTolSymmetrical  '对称显示公差。
bz1.TolerancePrecision = acDimPrecisionFour   '4位小数
bz1.ToleranceHeightScale = 0.5  '偏差文本高度为尺寸高度的一半。
'设置公差。
bz1.ToleranceLowerLimit = 0.3
bz1.ToleranceUpperLimit = 0.021

bz1.Update


Dim bz2 As AcadDimAligned                ''''''齿根圆
Dim point21(0 To 2) As Double
Dim point22(0 To 2) As Double
Dim location2(0 To 2) As Double


'定义尺寸标注。
point21(0) = zbjl + wide#: point21(1) = zxxsp + crf#: point21(2) = 0#
point22(0) = zbjl + wide#: point22(1) = zxxsp - crf#: point22(2) = 0#

location2(0) = zbjl + wide + 30#: location2(1) = 0#: location2(2) = 0#

'创建平行尺寸标注对象。
If Option6.Value = True Then
Set bz2 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point21, point22, location2)

Else
''''''''''''''''''''''''''''''''''自己写尺寸@@@@@@@@@@@@@@@
Set bz2 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point21, point22, location2)
Dim zbz2 As Integer
zbz2 = cm * (cz - 2.5)
bz2.TextOverride = zbz2

End If
                                        '标注公差。
bz2.DecimalSeparator = "."   '小数点符号。
'公差显示特性。
bz2.ToleranceDisplay = acTolSymmetrical  '对称显示公差。
bz2.TolerancePrecision = acDimPrecisionFour   '4位小数
bz2.ToleranceHeightScale = 0.5  '偏差文本高度为尺寸高度的一半。
'设置公差。
bz2.ToleranceLowerLimit = 0.015
bz2.ToleranceUpperLimit = 0.01

bz2.Update


Dim bz3 As AcadDimAligned             '''''''''内径
Dim point31(0 To 2) As Double
Dim point32(0 To 2) As Double
Dim location3(0 To 2) As Double


'定义尺寸标注。
point31(0) = zbjl + wide + 10#: point31(1) = zxxsp + clzbj#: point31(2) = 0#
point32(0) = zbjl + wide + 10#: point32(1) = zxxsp - clzbj#: point32(2) = 0#

location3(0) = zbjl + wide + 20#: location3(1) = 0#: location3(2) = 0#

'创建平行尺寸标注对象。
If Option6.Value = True Then
Set bz3 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point31, point32, location3)

Else
''''''''''''''''''''''''''''''''''自己写尺寸@@@@@@@@@@@@@@@
Set bz3 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point31, point32, location3)
Dim zbz3 As Integer
zbz3 = cm * (cz + 2) / 3
bz3.TextOverride = zbz3

End If
                                        '标注公差。
bz3.DecimalSeparator = "."   '小数点符号。
'公差显示特性。
bz3.ToleranceDisplay = acTolSymmetrical  '对称显示公差。
bz3.TolerancePrecision = acDimPrecisionFour   '4位小数
bz3.ToleranceHeightScale = 0.5  '偏差文本高度为尺寸高度的一半。
'设置公差。
bz3.ToleranceLowerLimit = 0.021
bz3.ToleranceUpperLimit = 0

bz3.Update


Dim bz4 As AcadDimAligned                ''''''分度圆 '''' 标注
Dim point41(0 To 2) As Double
Dim point42(0 To 2) As Double
Dim location4(0 To 2) As Double


'定义尺寸标注。
point41(0) = zbjl#: point41(1) = zxxsp - cra + dj#: point41(2) = 0#
point42(0) = zbjl + wide#: point42(1) = zxxsp - cra + dj#: point42(2) = 0#

location4(0) = 0#: location4(1) = zxxsp - cra - 10#: location4(2) = 0#

'创建平行尺寸标注对象。
If Option6.Value = True Then
Set bz4 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point41, point42, location4)

Else
''''''''''''''''''''''''''''''''''自己写尺寸@@@@@@@@@@@@@@@
Set bz4 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point41, point42, location4)
Dim zbz4 As Integer
zbz4 = cm * (cz - 2.5)
bz4.TextOverride = zbz4

End If
                                        '标注公差。
bz4.DecimalSeparator = "."   '小数点符号。
'公差显示特性。
bz4.ToleranceDisplay = acTolSymmetrical  '对称显示公差。
bz4.TolerancePrecision = acDimPrecisionFour   '4位小数
bz4.ToleranceHeightScale = 0.5  '偏差文本高度为尺寸高度的一半。
'设置公差。
bz4.ToleranceLowerLimit = 0.015
bz4.ToleranceUpperLimit = 0.01

bz4.Update















'画中心线。
'画分度圆

''定义线型（中心线）

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
'Set fdy1j = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpoint, cr)



'使用AcadLine对象的LineTypeScale属性               ''''''''点画线
'可以参考以下代码段:



'若线仍然看不清楚，可再加大线型比例。




'''由于中心线的线型与分度圆一致，故，放在一起。

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


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

Dim zxx3 As AcadLine '画竖的一段中心线。
Dim startpoint003(0 To 2) As Double
Dim endpoint003(0 To 2) As Double
startpoint003(0) = ybjl#: startpoint003(1) = zxxsp + cra + 10#: startpoint003(2) = 0#
endpoint003(0) = ybjl#: endpoint003(1) = zxxsp - cra - 10#: endpoint003(2) = 0#
Set zxx3 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint003, endpoint003)

Dim x2j As AcadLine  'jl
Dim startpoint0002j(0 To 2) As Double
Dim endpoint0002j(0 To 2) As Double
startpoint0002j(0) = zbjl - 10#: startpoint0002j(1) = zxxsp + clzbj + 15#: startpoint0002j(2) = 0#
endpoint0002j(0) = zbjl - 10#: endpoint0002j(1) = zxxsp - clzbj - 15#: endpoint0002j(2) = 0#
Set x2j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint0002j, endpoint0002j)

Dim x3j As AcadLine  'np
Dim startpoint0003j(0 To 2) As Double
Dim endpoint0003j(0 To 2) As Double
startpoint0003j(0) = zbjl + wide + 10#: startpoint0003j(1) = zxxsp + clzbj + 15#: startpoint0003j(2) = 0#
endpoint0003j(0) = zbjl + wide + 10#: endpoint0003j(1) = zxxsp - clzbj - 15#: endpoint0003j(2) = 0#
Set x3j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint0003j, endpoint0003j)

Dim x4j As AcadLine  '分度圆上
Dim startpoint0004j(0 To 2) As Double
Dim endpoint0004j(0 To 2) As Double
startpoint0004j(0) = zbjl - 8#: startpoint0004j(1) = zxxsp + cr#: startpoint0004j(2) = 0#
endpoint0004j(0) = zbjl + wide + 8#: endpoint0004j(1) = zxxsp + cr#: endpoint0004j(2) = 0#
Set x4j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint0004j, endpoint0004j)

Dim x5j As AcadLine  '分度圆下
Dim startpoint0005j(0 To 2) As Double
Dim endpoint0005j(0 To 2) As Double
startpoint0005j(0) = zbjl - 8#: startpoint0005j(1) = zxxsp - cr#: startpoint0005j(2) = 0#
endpoint0005j(0) = zbjl + wide + 8#: endpoint0005j(1) = zxxsp - cr#: endpoint0005j(2) = 0#
Set x5j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint0005j, endpoint0005j)



Dim jy As AcadCircle         '节圆
Dim centerpointjy(0 To 2) As Double
centerpointjy(0) = ybjl#: centerpointjy(1) = zxxsp#: centerpointjy(2) = 0#:
Set jy = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointjy, cr)

jy.Lineweight = acLnWt30




Dim bz5 As AcadDimAligned                ''''''分度圆 '''' 标注
Dim point51(0 To 2) As Double
Dim point52(0 To 2) As Double
Dim location5(0 To 2) As Double


'定义尺寸标注。
point51(0) = zbjl + wide + 10#: point51(1) = zxxsp + cr#: point51(2) = 0#
point52(0) = zbjl + wide + 10#: point52(1) = zxxsp - cr#: point52(2) = 0#

location5(0) = zbjl + wide + 40#: location5(1) = 0#: location5(2) = 0#

'创建平行尺寸标注对象。
If Option6.Value = True Then
Set bz5 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point51, point52, location5)

Else
''''''''''''''''''''''''''''''''''自己写尺寸@@@@@@@@@@@@@@@
Set bz5 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point51, point52, location5)
Dim zbz5 As Integer
zbz5 = cm * (cz - 2.5)
bz5.TextOverride = zbz5

End If
                                        '标注公差。
bz5.DecimalSeparator = "."   '小数点符号。
'公差显示特性。
bz5.ToleranceDisplay = acTolSymmetrical  '对称显示公差。
bz5.TolerancePrecision = acDimPrecisionFour   '4位小数
bz5.ToleranceHeightScale = 0.5  '偏差文本高度为尺寸高度的一半。
'设置公差。
bz5.ToleranceLowerLimit = 0.015
bz5.ToleranceUpperLimit = 0.01

bz5.Update





End Sub

Private Sub Command3_Click()
Unload Me
Form011.Show
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 Form_Load()




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

'链接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


End Sub