form013斜齿轮实心式.frm

锥齿轮CAD设计

e = 10
End If

If Option5.Value = True Then        'A4
tzc = 297
tzg = 210
e = 10
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   '图框长tkc
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 zbjl As Double         '左，右，上，下 边距离
Dim ybjl As Double
Dim sbjl As Double
Dim xbjl As Double

Dim dwxz As Double          '定位线左-左侧面线
Dim zxxsp As Double          '中心线左-水平线
Dim zxxy As Double          '中心线右-竖线

Dim wide As Double          '齿轮宽
Dim dj As Double            '倒角
Dim nj As Double            '内径-半径
Dim ndj As Double           '内倒角

Dim ha As Double             '齿顶高
Dim hf As Double             '齿根高
Dim r As Double              '锥距
Dim aa As Double             '顶锥角
Dim a As Double              '分锥角
Dim af As Double             '根锥角



dwxz = zbjl
zxxsp = tzg / 2 + 20
zxxy = tzc - 2 * e - tkc / 4

wide = 40
dj = 2
ndj = 2
nj = Text11.Text

ybjl = zxxy
ha = m
hf = 1.2 * m
'r= (cz^2+czd^2)*m/2
'a1 = arctan(cz / czd)
'aa1 = a1 + arctan(hf / r)
'af1 = a1 - arctan(hf / r)



If Option5.Value Then
zbjl = 40
End If

If Option4.Value Then
zbjl = 50
End If

If Option3.Value Then
zbjl = 60
End If
 
If Option2.Value Then
zbjl = 70
End If

If Option1.Value Then
zbjl = 80
End If


                                              ''''''''''''''''''''''''左视图

Dim ab As AcadLine ''''''''''''''
Dim startpointab(0 To 2) As Double
Dim endpointab(0 To 2) As Double
startpointab(0) = zbjl#: startpointab(1) = zxxsp + crf#: startpointab(2) = 0#
endpointab(0) = zbjl#: endpointab(1) = zxxsp - cra + 2#: endpointab(2) = 0#
Set ab = acadapp.ActiveDocument.ModelSpace.AddLine(startpointab, endpointab)

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

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

Dim de As AcadLine
Dim startpointde(0 To 2) As Double
Dim endpointde(0 To 2) As Double
startpointde(0) = zbjl + wide - dj#: startpointde(1) = zxxsp - cra#: startpointde(2) = 0#
endpointde(0) = zbjl + wide#: endpointde(1) = zxxsp - cra + dj#: endpointde(2) = 0#
Set de = acadapp.ActiveDocument.ModelSpace.AddLine(startpointde, endpointde)

Dim ef As AcadLine
Dim startpointef(0 To 2) As Double
Dim endpointef(0 To 2) As Double
startpointef(0) = zbjl + wide#: startpointef(1) = zxxsp - cra + dj#: startpointef(2) = 0#
endpointef(0) = zbjl + wide#: endpointef(1) = zxxsp + cra - dj#: endpointef(2) = 0#
Set ef = acadapp.ActiveDocument.ModelSpace.AddLine(startpointef, endpointef)

Dim fg As AcadLine
Dim startpointfg(0 To 2) As Double
Dim endpointfg(0 To 2) As Double
startpointfg(0) = zbjl + wide#: startpointfg(1) = zxxsp + cra - dj#: startpointfg(2) = 0#
endpointfg(0) = zbjl + wide - dj#: endpointfg(1) = zxxsp + cra#: endpointfg(2) = 0#
Set fg = acadapp.ActiveDocument.ModelSpace.AddLine(startpointfg, endpointfg)

Dim gh As AcadLine
Dim startpointgh(0 To 2) As Double
Dim endpointgh(0 To 2) As Double
startpointgh(0) = zbjl + wide - dj#: startpointgh(1) = zxxsp + cra#: startpointgh(2) = 0#
endpointgh(0) = zbjl + dj#: endpointgh(1) = zxxsp + cra#: endpointgh(2) = 0#
Set gh = acadapp.ActiveDocument.ModelSpace.AddLine(startpointgh, endpointgh)

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

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 jk As AcadLine
Dim startpointjk(0 To 2) As Double
Dim endpointjk(0 To 2) As Double
startpointjk(0) = zbjl#: startpointjk(1) = zxxsp + nj + ndj#: startpointjk(2) = 0#
endpointjk(0) = zbjl + dj#: endpointjk(1) = zxxsp + nj#: endpointjk(2) = 0#
Set jk = acadapp.ActiveDocument.ModelSpace.AddLine(startpointjk, endpointjk)

Dim kl As AcadLine
Dim startpointkl(0 To 2) As Double
Dim endpointkl(0 To 2) As Double
startpointkl(0) = zbjl + dj#: startpointkl(1) = zxxsp + nj#: startpointkl(2) = 0#
endpointkl(0) = zbjl + wide - dj#: endpointkl(1) = zxxsp + nj#: endpointkl(2) = 0#
Set kl = acadapp.ActiveDocument.ModelSpace.AddLine(startpointkl, endpointkl)

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

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 - nj - dj#: startpointno(2) = 0#
endpointno(0) = zbjl + wide - dj#: endpointno(1) = zxxsp - nj#: endpointno(2) = 0#
Set no = acadapp.ActiveDocument.ModelSpace.AddLine(startpointno, endpointno)

Dim op As AcadLine
Dim startpointop(0 To 2) As Double
Dim endpointop(0 To 2) As Double
startpointop(0) = zbjl + wide - dj#: startpointop(1) = zxxsp - nj#: startpointop(2) = 0#
endpointop(0) = zbjl + dj#: endpointop(1) = zxxsp - nj#: endpointop(2) = 0#
Set op = acadapp.ActiveDocument.ModelSpace.AddLine(startpointop, endpointop)

Dim pq As AcadLine
Dim