form13.frm

很好的齿轮cad参数化设计程序

'画齿轮剖视图。

Dim d0 As Double
Dim d1 As Double  '定义剖视图上的X轴方向上的点（d0,d1,d2,d7,d8,d15,d16,d17,d18,d30,35,d36)；
                  '定义剖视图的Y轴上的点（d3,d4,d5,d6,d9,d10,d11,d12,d13,d14,d19,d20,d21,d22,
                  'd23,d24,d25,d26,d27,d28,d31,d32,d33,d34,d35,d36,d37,d38)。
Dim d2 As Double
Dim d3 As Double
Dim d4 As Double
Dim d5 As Double
Dim d6 As Double
Dim d7 As Double
Dim d8 As Double
Dim d9 As Double
Dim d10 As Double
Dim d11 As Double
Dim d12 As Double
Dim d13 As Double
Dim d14 As Double
Dim d15 As Double
Dim d16 As Double
Dim d17 As Double
Dim d18 As Double
Dim d19 As Double
Dim d20 As Double
Dim d21 As Double
Dim d22 As Double
Dim d23 As Double
Dim d24 As Double
Dim d25 As Double
Dim d26 As Double
Dim d27 As Double
Dim d28 As Double
Dim d29 As Double
Dim d30 As Double
Dim d31 As Double
Dim d32 As Double
Dim d33 As Double
Dim d34 As Double
Dim d35 As Double
Dim d36 As Double
Dim d37 As Double
Dim d38 As Double
Dim d39 As Double
Dim d40 As Double
Dim d41 As Double
Dim d42 As Double



d0 = zjl + ch / 2   '“ch”为齿厚。
d1 = zjl
d2 = zjl + ch
d3 = zxx06 + cra / 3
d4 = zxx06 + crf
d5 = zxx06 + cr
d6 = zxx06 + cra
d7 = d1 + cm / 2
d8 = d2 - cm / 2
d9 = zxx06 - cra / 3
d10 = zxx06 - crf
d11 = zxx06 - cr
d12 = zxx06 - cra
d13 = d6 - cm / 2
d14 = d12 + cm / 2
d15 = zjl - 10
d16 = d2 + 10
d17 = d1 + 0.35 * ch
d18 = d2 - 0.35 * ch
d19 = d3 + 2
d21 = zxx06 + vd1 / 2
d20 = d21 - 2
d22 = zxx06 + vdd0 / 2
d23 = d22 + (vdd0 - vd1) / 2
d24 = d23 + 2
d25 = d9 - 2
d26 = zxx06 - vd1 / 2
d37 = zxx06 - vdd0 / 2
d27 = d37 - (vdd0 - vd1) / 2
d28 = d27 - 2
d29 = d1 + 2
d30 = d2 - 2
d31 = d22 + vd0 / 2
d32 = d22 - vd0 / 2
d33 = d37 + vd0 / 2
d34 = d37 - vd0 / 2
d35 = d1 + 2
d36 = d2 - 2
d38 = d26 + 2
d39 = d1 + 2
d40 = d2 - 2
d41 = d3 + 2
d42 = d9 - 2

Dim centerpoint(0 To 2) As Double
centerpoint(0) = zxx07#: centerpoint(1) = zxx06#: centerpoint(2) = 0#:

Dim hatchobj1 As AcadHatch
Dim hatchobj2 As AcadHatch
Dim hatchobj3 As AcadHatch
Dim hatchobj4 As AcadHatch
Dim hatchobj5 As AcadHatch
Dim hatchobj6 As AcadHatch
Dim patternname As String
Dim patterntype As Long
Dim bassociativity As Boolean
''定义填充。
patterntype = 0
patternname = "ANSI31"
bassociativity = True



'标注。

''齿厚。

Dim bz1 As AcadDimAligned
Dim point10(0 To 2) As Double
Dim point11(0 To 2) As Double
Dim location1(0 To 2) As Double

Dim d0014 As Double
d0014 = d14 - 8


'定义尺寸标注。
point10(0) = d1#: point10(1) = d14#: point10(2) = 0#
point11(0) = d2#: point11(1) = d14#: point11(2) = 0#

location1(0) = d1#: location1(1) = d0014#: location1(2) = 0#

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

Else
'自己写尺寸。
Set bz1 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point10, point11, 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.15
bz1.ToleranceUpperLimit = 0.1

bz1.Update



''轴孔。

Dim bz2 As AcadDimAligned
Dim point20(0 To 2) As Double
Dim point21(0 To 2) As Double
Dim location2(0 To 2) As Double

'定义尺寸标注。
point20(0) = d1#: point20(1) = d3#: point20(2) = 0#
point21(0) = d1#: point21(1) = d9#: point21(2) = 0#

Dim bd2 As Double
bd2 = d1 - 5

location2(0) = bd2#: location2(1) = bd2#: location2(2) = 0#

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

Else
'自己写尺寸。
Set bz2 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point20, point21, location2)
Dim zbz2 As Integer
zbz2 = cm * (cz + 2) / 3
bz2.TextOverride = zbz2
End If
'标注公差。

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

bz2.Update




''齿根圆。

Dim bz3 As AcadDimAligned
Dim point30(0 To 2) As Double
Dim point31(0 To 2) As Double
Dim location3(0 To 2) As Double

'定义尺寸标注。
point30(0) = d1#: point30(1) = d4#: point30(2) = 0#
point31(0) = d1#: point31(1) = d10#: point31(2) = 0#

Dim bd3 As Double
bd3 = d1 - 13

location3(0) = bd3#: location3(1) = bd3#: location3(2) = 0#

'创建平行尺寸标注对象。
If Option6.Value = True Then
Set bz3 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point30, point31, location3)
Else
'自己写尺寸。
Set bz3 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point30, point31, location3)
Dim zbz3 As Integer
zbz3 = cm * (cz - 2.5)
bz3.TextOverride = zbz3
End If
'标注公差。

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

bz3.Update




''分度圆。

Dim bz4 As AcadDimAligned
Dim point40(0 To 2) As Double
Dim point41(0 To 2) As Double
Dim location4(0 To 2) As Double

'定义尺寸标注。
point40(0) = d15#: point40(1) = d5#: point40(2) = 0#
point41(0) = d15#: point41(1) = d11#: point41(2) = 0#

Dim bd4 As Double
bd4 = d1 - 21

location4(0) = bd4#: location4(1) = bd4#: location4(2) = 0#

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

Dim zbz4 As Integer
zbz4 = cm * cz
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



''齿顶圆。

Dim bz5 As AcadDimAligned
Dim point50(0 To 2) As Double
Dim point51(0 To 2) As Double
Dim location5(0 To 2) As Double

'定义尺寸标注。
point50(0) = d7#: point50(1) = d6#: point50(2) = 0#
point51(0) = d7#: point51(1) = d12#: point51(2) = 0#

Dim bd5 As Double
bd5 = d1 - 29

location5(0) = bd5#: location5(1) = bd5#: location5(2) = 0#

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

'自己写尺寸。
Set bz5 = acadapp.ActiveDocument.ModelSpace.AddDimAligned(point50, point51, location5)
Dim zbz5 As Integer
zbz5 = cm * cz + 2 * cm
bz5.TextOverride = zbz5
End If


'标注公差。

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


bz5.Update



If vvv > 100 Then

Dim y1 As AcadLine
Dim startpointy1(0 To 2) As Double
Dim endpointy1(0 To 2) As Double
startpointy1(0) = d7#: startpointy1(1) = d12#: startpointy1(2) = 0#
endpointy1(0) = d8#: endpointy1(1) = d12#: endpointy1(2) = 0#
Set y1 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy1, endpointy1)

Dim y2 As AcadLine
Dim startpointy2(0 To 2) As Double
Dim endpointy2(0 To 2) As Double
startpointy2(0) = d7#: startpointy2(1) = d12#: startpointy2(2) = 0#
endpointy2(0) = d1#: endpointy2(1) = d14#: endpointy2(2) = 0#
Set y2 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy2, endpointy2)

Dim y3 As AcadLine
Dim startpointy3(0 To 2) As Double
Dim endpointy3(0 To 2) As Double
startpointy3(0) = d8#: startpointy3(1) = d12#: startpointy3(2) = 0#
endpointy3(0) = d2#: endpointy3(1) = d14#: endpointy3(2) = 0#
Set y3 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy3, endpointy3)

'Dim y4 As AcadLine '(zhong xin xian)
'Dim startpointy4(0 To 2) As Double
'Dim endpointy4(0 To 2) As Double
'startpointy4(0) = d15#: startpointy4(1) = d11#: startpointy4(2) = 0#
'endpointy4(0) = d16#: endpointy4(1) = d11#: endpointy4(2) = 0#
'Set y4 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy4, endpointy4)

Dim y5 As AcadLine
Dim startpointy5(0 To 2) As Double
Dim endpointy5(0 To 2) As Double
startpointy5(0) = d1#: startpointy5(1) = d10#: startpointy5(2) = 0#
endpointy5(0) = d2#: endpointy5(1) = d10#: endpointy5(2) = 0#
Set y5 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy5, endpointy5)

Dim y6 As AcadLine
Dim startpointy6(0 To 2) As Double
Dim endpointy6(0 To 2) As Double
startpointy6(0) = d1#: startpointy6(1) = d14#: startpointy6(2) = 0#
endpointy6(0) = d1#: endpointy6(1) = d13#: endpointy6(2) = 0#
Set y6 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy6, endpointy6)

Dim y7 As AcadLine
Dim startpointy7(0 To 2) As Double
Dim endpointy7(0 To 2) As Double
startpointy7(0) = d2#: startpointy7(1) = d14#: startpointy7(2) = 0#
endpointy7(0) = d2#: endpointy7(1) = d13#: endpointy7(2) = 0#
Set y7 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy7, endpointy7)

Dim y8 As AcadLine
Dim startpointy8(0 To 2) As Double
Dim endpointy8(0 To 2) As Double
startpointy8(0) = d1#: startpointy8(1) = d28#: startpointy8(2) = 0#
endpointy8(0) = d29#: endpointy8(1) = d27#: endpointy8(2) = 0#
Set y8 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy8, endpointy8)

Dim y9 As AcadLine
Dim startpointy9(0 To 2) As Double
Dim endpointy9(0 To 2) As Double
startpointy9(0) = d29#: startpointy9(1) = d27#: startpointy9(2) = 0#
endpointy9(0) = d17#: endpointy9(1) = d27#: endpointy9(2) = 0#
Set y9 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy9, endpointy9)

Dim y10 As AcadLine
Dim startpointy10(0 To 2) As Double
Dim endpointy10(0 To 2) As Double
startpointy10(0) = d17#: startpointy10(1) = d34#: startpointy10(2) = 0#
endpointy10(0) = d18#: endpointy10(1) = d34#: endpointy10(2) = 0#
Set y10 = acadapp.ActiveDocument.ModelSpace.AddLine(startpointy10, endpointy10)

Dim y11 As AcadLine
Dim startpointy11(0 To 2) As Double
Dim endpointy11(0 To 2) As Double
startpointy11(0) = d18#: startpointy11(1) = d27#: startpointy11(2) = 0#