form13.frm

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

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

cz = Text1.Text                   '齿数
cm = Text2.Text                   '模数
ca = Text3.Text * 3.1415926 / 180 '压力角
czd = Text10.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


Dim zjl As Double   '定义不同图纸的不同左右上下距离。(zuo)
Dim yjl As Double  '(you ju li)
Dim sjl As Double  '(shang ju li)
Dim xjl As Double  '(xia ju li)

If Option5.Value = True Then
zjl = 40
yjl = 40

End If

If Option4.Value = True Then
zjl = 50
yjl = 50

End If

If Option3.Value = True Then
zjl = 70
yjl = 70

End If

If Option2.Value = True Then
zjl = 80
yjl = 80

End If

If Option1.Value = True Then
zjl = 90
yjl = 90

End If




Dim tzdx1 As Double
Dim tzdx2 As Double
Dim tzdy1 As Double
Dim tzdy2 As Double

tzdx1 = -e
tzdx2 = tzc - e
tzdy1 = -e
tzdy2 = tzg - e




Dim tz As AcadLWPolyline
Dim points90(0 To 9) As Double '(-10,-10),(277,-10),(277,200),(-10,200),(-10,-10)
points90(0) = tzdx1: points90(1) = tzdy1
points90(2) = tzdx2: points90(3) = tzdy1
points90(4) = tzdx2: points90(5) = tzdy2
points90(6) = tzdx1: points90(7) = tzdy2
points90(8) = tzdx1: points90(9) = tzdy1

Set tz = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points90)



'画图框（粗实线）。

Dim tkc As Double  '图框长
Dim tkg As Double  '图框高

tkc = tzc - 2 * e '选A4图纸
tkg = tzg - 2 * e




Dim tk As AcadLWPolyline
Dim points0(0 To 9) As Double '(0,0),(287,0),(287,200),(0,200),(0,0)
points0(0) = 0: points0(1) = 0
points0(2) = tkc: points0(3) = 0
points0(4) = tkc: points0(5) = tkg
points0(6) = 0: points0(7) = tkg
points0(8) = 0: points0(9) = 0

Set tk = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points0)

tk.Lineweight = acLnWt030


'画标题栏(粗细实线）。

''粗实线部分。

Dim btkc As AcadLWPolyline
Dim points1(0 To 5) As Double '(157,0),(157,40),(287,40)
points1(0) = (tkc - 130): points1(1) = 0
points1(2) = (tkc - 130): points1(3) = 40
points1(4) = tkc: points1(5) = 40

Set btkc = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points1)

btkc.Lineweight = acLnWt030

''细实线部分。（画线顺序为由下到上，由左到右）

Dim tkc0 As Double  '定义图框栏中X轴交点的坐标，从左到右。
Dim tkc1 As Double
Dim tkc2 As Double
Dim tkc3 As Double
Dim tkc4 As Double
Dim tkc5 As Double
Dim tkc6 As Double

tkc0 = tkc - 130
tkc1 = tkc - 130 + 12
tkc2 = tkc - 130 + 40
tkc3 = tkc - 130 + 65
tkc4 = tkc - 130 + 65 + 12
tkc5 = tkc - 130 + 65 + 30
tkc6 = tkc - 23


Dim btkx0 As AcadLine
Dim startpoint0(0 To 2) As Double '(157,8),(222,8)
Dim endpoint0(0 To 2) As Double
startpoint0(0) = tkc0#: startpoint0(1) = 8#: startpoint0(2) = 0#
endpoint0(0) = tkc3#: endpoint0(1) = 8#: endpoint0(2) = 0#
Set btkx0 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint0, endpoint0)

Dim btkx1 As AcadLine
Dim startpoint1(0 To 2) As Double '(157,16),(287,16)
Dim endpoint1(0 To 2) As Double
startpoint1(0) = tkc0#: startpoint1(1) = 16#: startpoint1(2) = 0#
endpoint1(0) = tkc#: endpoint1(1) = 16#: endpoint1(2) = 0#
Set btkx1 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint1, endpoint1)

Dim btkx2 As AcadLine
Dim startpoint2(0 To 2) As Double '(157,24),(287,24)
Dim endpoint2(0 To 2) As Double
startpoint2(0) = tkc0#: startpoint2(1) = 24#: startpoint2(2) = 0#
endpoint2(0) = tkc#: endpoint2(1) = 24#: endpoint2(2) = 0#
Set btkx2 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint2, endpoint2)

Dim btkx3 As AcadLine
Dim startpoint3(0 To 2) As Double '(222,32),(252,32)
Dim endpoint3(0 To 2) As Double
startpoint3(0) = tkc3#: startpoint3(1) = 32#: startpoint3(2) = 0#
endpoint3(0) = tkc5#: endpoint3(1) = 32#: endpoint3(2) = 0#
Set btkx3 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint3, endpoint3)

'''开始竖线。

Dim btkx4 As AcadLine
Dim startpoint4(0 To 2) As Double '(169,24),(169,0)
Dim endpoint4(0 To 2) As Double
startpoint4(0) = tkc1#: startpoint4(1) = 24#: startpoint4(2) = 0#
endpoint4(0) = tkc1#: endpoint4(1) = 0#: endpoint4(2) = 0#
Set btkx4 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint4, endpoint4)

Dim btkx5 As AcadLine
Dim startpoint5(0 To 2) As Double '(197,24),(197,0)
Dim endpoint5(0 To 2) As Double
startpoint5(0) = tkc2#: startpoint5(1) = 24#: startpoint5(2) = 0#
endpoint5(0) = tkc2#: endpoint5(1) = 0#: endpoint5(2) = 0#
Set btkx5 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint5, endpoint5)

Dim btkx6 As AcadLine
Dim startpoint6(0 To 2) As Double '(222,40),(222,0)
Dim endpoint6(0 To 2) As Double
startpoint6(0) = tkc3#: startpoint6(1) = 40#: startpoint6(2) = 0#
endpoint6(0) = tkc3#: endpoint6(1) = 0#: endpoint6(2) = 0#
Set btkx6 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint6, endpoint6)

Dim btkx7 As AcadLine
Dim startpoint7(0 To 2) As Double '(234,40),(234,16)
Dim endpoint7(0 To 2) As Double
startpoint7(0) = tkc4#: startpoint7(1) = 40#: startpoint7(2) = 0#
endpoint7(0) = tkc4#: endpoint7(1) = 16#: endpoint7(2) = 0#
Set btkx7 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint7, endpoint7)

Dim btkx8 As AcadLine
Dim startpoint8(0 To 2) As Double '(252,40),(252,16)
Dim endpoint8(0 To 2) As Double
startpoint8(0) = tkc5#: startpoint8(1) = 40#: startpoint8(2) = 0#
endpoint8(0) = tkc5#: endpoint8(1) = 16#: endpoint8(2) = 0#
Set btkx8 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint8, endpoint8)

Dim btkx9 As AcadLine
Dim startpoint9(0 To 2) As Double '(264,24),(264,16)
Dim endpoint9(0 To 2) As Double
startpoint9(0) = tkc6#: startpoint9(1) = 24#: startpoint9(2) = 0#
endpoint9(0) = tkc6#: endpoint9(1) = 16#: endpoint9(2) = 0#
Set btkx9 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint9, endpoint9)


'画右上角齿轮说明框。(从下到上，从左到右，细实线。）

Dim smkx As AcadLine
Dim startpoint(0 To 2) As Double '(264,24),(264,16)
Dim endpoint(0 To 2) As Double
startpoint(0) = smkc#: startpoint(1) = smkg#: startpoint(2) = 0#
endpoint(0) = smkc#: endpoint(1) = smkg#: endpoint(2) = 0#
Set smkx = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint, endpoint)


Dim smkc0 As Double  '定义说明图框栏中X轴交点的坐标，从左到右。
Dim smkc1 As Double

smkc0 = tkc - 65
smkc1 = tkc - 35

Dim smkg0 As Double  '定义说明图框栏中y轴交点的坐标，从下到上。
Dim smkg1 As Double
Dim smkg2 As Double

smkg0 = tkg - 24
smkg1 = tkg - 16
smkg2 = tkg - 8

Dim smkx0 As AcadLine
Dim startpoint00(0 To 2) As Double '(222,186),(287,186)
Dim endpoint00(0 To 2) As Double
startpoint00(0) = smkc0#: startpoint00(1) = smkg0#: startpoint00(2) = 0#
endpoint00(0) = tkc#: endpoint00(1) = smkg0#: endpoint00(2) = 0#
Set smkx0 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint00, endpoint00)

Dim smkx1 As AcadLine
Dim startpoint01(0 To 2) As Double '(222,194),(287,194)
Dim endpoint01(0 To 2) As Double
startpoint01(0) = smkc0#: startpoint01(1) = smkg1#: startpoint01(2) = 0#
endpoint01(0) = tkc#: endpoint01(1) = smkg1#: endpoint01(2) = 0#
Set smkx1 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint01, endpoint01)

Dim smkx2 As AcadLine
Dim startpoint02(0 To 2) As Double '(222,202),(287,202)
Dim endpoint02(0 To 2) As Double
startpoint02(0) = smkc0#: startpoint02(1) = smkg2#: startpoint02(2) = 0#
endpoint02(0) = tkc#: endpoint02(1) = smkg2#: endpoint02(2) = 0#
Set smkx2 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint02, endpoint02)


'''画竖线.

Dim smkx3 As AcadLine
Dim startpoint03(0 To 2) As Double '(222,200),(222,186)
Dim endpoint03(0 To 2) As Double
startpoint03(0) = smkc0#: startpoint03(1) = tkg#: startpoint03(2) = 0#
endpoint03(0) = smkc0#: endpoint03(1) = smkg0#: endpoint03(2) = 0#
Set smkx3 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint03, endpoint03)

Dim smkx4 As AcadLine
Dim startpoint04(0 To 2) As Double '(252,200),(252,186)
Dim endpoint04(0 To 2) As Double
startpoint04(0) = smkc1#: startpoint04(1) = tkg#: startpoint04(2) = 0#
endpoint04(0) = smkc1#: endpoint04(1) = smkg0#: endpoint04(2) = 0#
Set smkx4 = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint04, endpoint04)



'画总体中心线。

Dim zxx00 As Double   '中心线在X轴起始与终止点。依次从左到右，从上到下。 ???怎么实现图纸选择的不同，它也不同？
Dim zxx01 As Double
Dim zxx02 As Double
Dim zxx03 As Double

Dim zxx04 As Double   '中心在Y轴的起点与终点坐标。
Dim zxx05 As Double

Dim zxx06 As Double   '定义中心线Y轴的坐标，与X轴的坐标。
Dim zxx07 As Double


Dim ch As Double
'ch = cra * 2 / 3

If Form9.Option15.Value = True Then
ch = 2 * cr * 1
ElseIf Form9.Option17.Value = True Then
ch = 2 * cr * 0.5
Else
ch = 2 * cr * 0.8
End If







zxx00 = zjl - 10
zxx01 = zjl + ch + 10  '“ch”为“齿轮厚度”，通常取为齿顶圆的1/3。????

zxx03 = tkc - yjl + 10
zxx02 = zxx03 - 2 * cra - 20

zxx06 = tkg / 2 + 20
zxx07 = tkc - yjl - cra '以上为定义画中心线时的点。

zxx04 = zxx06 + cra + 10
zxx05 = zxx06 - cra - 10

Dim vvv As Double
vvv = (cm * cz + 2 * cm) / 2

Dim vd0 As Double
Dim vd1 As Double
Dim vdd0 As Double
Dim vdd1 As Double

vd1 = 1.6 * 2 * cra / 3
vdd1 = 2 * cra - 10 * cm * u
vdd0 = 0.5 * (vdd1 + vd1)
vd0 = 0.25 * (vdd1 - vd1)