form01.frm

锥齿轮CAD设计

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           '内倒角



dwxz = zbjl
zxxsp = tzg / 2 + 20
zxxy = tzc - 2 * e - tkc / 4
wide = 40
dj = 2
ndj = 2
nj = 10
ybjl = zxxy


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


Dim kp As AcadLine
Dim startpointkp(0 To 2) As Double
Dim endpointkp(0 To 2) As Double
startpointkp(0) = zbjl + dj#: startpointkp(1) = zxxsp + nj#: startpointkp(2) = 0#
endpointkp(0) = zbjl + dj#: endpointkp(1) = zxxsp - nj#: endpointkp(2) = 0#
Set kp = acadapp.ActiveDocument.ModelSpace.AddLine(startpointkp, endpointkp)

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

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 tu As AcadLine
Dim startpointtu(0 To 2) As Double
Dim endpointtu(0 To 2) As Double
startpointtu(0) = zbjl#: startpointtu(1) = zxxsp + crf#: startpointtu(2) = 0#
endpointtu(0) = zbjl + wide#: endpointtu(1) = zxxsp + crf#: endpointtu(2) = 0#
Set tu = acadapp.ActiveDocument.ModelSpace.AddLine(startpointtu, endpointtu)




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

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, nj)

nk.Lineweight = acLnWt30

Dim nkdj As AcadCircle         '内孔倒角圆
Dim centerpointnkdj(0 To 2) As Double
centerpointnkdj(0) = ybjl#: centerpointnkdj(1) = zxxsp#: centerpointnkdj(2) = 0#:
Set nkdj = acadapp.ActiveDocument.ModelSpace.AddCircle(centerpointnkdj, nj + 2)

'acadapp.ActiveDocument.Preferences.LineWeightDisplay = True


nkdj.Lineweight = acLnWt030


                                                 '''''''''''标题栏（btl）书写

Dim styobj1 As AcadTextStyle  '定义格式一。
Dim typeface As String
Dim bold As Boolean
Dim italic As Boolean
Dim charset As Long
Dim pitchandfamily As Long
Set styobj1 = acadapp.ActiveDocument.TextStyles.Add("样式一")
typeface = "宋体"
italic = False
bold = False
charset = 1
pitchandfamily = 1  '？
styobj1.SetFont typeface, bold, italic, charest, pitchandfimily

Dim styobj2 As AcadTextStyle  '定义样式二。
Set styobj2 = acadapp.ActiveDocument.TextStyles.Add("样式二")
styobj2.fontFile = "c:\windows\fonts\simhei.ttf"            '仿宋体'



Dim btl1 As AcadText
Dim textstring1 As String
Dim height1 As Double
Dim insertionpoint1(0 To 2) As Double
'定义文字的高度和书写位置
textstring1 = "小齿轮"
height1 = 8
insertionpoint1(0) = tkc - 130 + 3#: insertionpoint1(1) = 29: insertionpoint1(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl1 = acadapp.ActiveDocument.ModelSpace.AddText(textstring1, insertionpoint1, height1)

Dim btl2 As AcadText
Dim textstring2 As String
Dim height2 As Double
Dim insertionpoint2(0 To 2) As Double
'定义文字的高度和书写位置
textstring2 = "比例"
height2 = 3.5
insertionpoint2(0) = tkc - 65 + 1#: insertionpoint2(1) = 33.5: insertionpoint2(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl2 = acadapp.ActiveDocument.ModelSpace.AddText(textstring2, insertionpoint2, height2)

Dim btl3 As AcadText           '''比例
Dim textstring3 As String
Dim height3 As Double
Dim insertionpoint3(0 To 2) As Double
'定义文字的高度和书写位置

If Option6.Value = True Then
textstring3 = "1:1"
End If

If Option7.Value = True Then
textstring3 = "1:2"
End If

If Option8.Value = True Then
textstring3 = "1:5"
End If

If Option9.Value = True Then
textstring3 = "1:10"
End If

If Option10.Value = True Then
textstring3 = "5:1"
End If

If Option11.Value = True Then
textstring3 = "2:1"
End If

height3 = 3.5
insertionpoint3(0) = tkc - 53 + 1#: insertionpoint3(1) = 33.5: insertionpoint3(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl3 = acadapp.ActiveDocument.ModelSpace.AddText(textstring3, insertionpoint3, height3)


Dim btl4 As AcadText
Dim textstring4 As String
Dim height4 As Double
Dim insertionpoint4(0 To 2) As Double
'定义文字的高度和书写