form013斜齿轮实心式.frm

锥齿轮CAD设计

insertionpointsmk4(0) = tkc - 35 + 2#: insertionpointsmk4(1) = tkg - 14: insertionpointsmk4(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set smk4 = acadapp.ActiveDocument.ModelSpace.AddText(textstringsmk4, insertionpointsmk4, heightsmk4)

Dim smk5 As AcadText
Dim textstringsmk5 As String
Dim heightsmk5 As Double
Dim insertionpointsmk5(0 To 2) As Double
'定义文字的高度和书写位置
textstringsmk5 = "压力角(a)"
heightsmk5 = 3.5
insertionpointsmk5(0) = tkc - 65 + 2#: insertionpointsmk5(1) = tkg - 22: insertionpointsmk5(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set smk5 = acadapp.ActiveDocument.ModelSpace.AddText(textstringsmk5, insertionpointsmk5, heightsmk5)

Dim smk6 As AcadText
Dim textstringsmk6 As String
Dim heightsmk6 As Double
Dim insertionpointsmk6(0 To 2) As Double
'定义文字的高度和书写位置
textstringsmk6 = Text4.Text
heightsmk6 = 3.5
insertionpointsmk6(0) = tkc - 35 + 2#: insertionpointsmk6(1) = tkg - 22: insertionpointsmk6(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set smk6 = acadapp.ActiveDocument.ModelSpace.AddText(textstringsmk6, insertionpointsmk6, heightsmk6)



 
 '画齿轮剖视图。

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 + crf#: startpointjk(2) = 0#
endpointjk(0) = zbjl + wide#: endpointjk(1) = zxxsp + crf#: 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#: startpointlm(1) = zxxsp - crf#: startpointlm(2) = 0#
endpointlm(0) = zbjl + wide#: endpointlm(1) = zxxsp - crf#: 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#: startpointno(1) = zxxsp + nj#: startpointno(2) = 0#
endpointno(0) = zbjl + wide#: endpointno(1) = zxxsp + nj#: 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 - nj#: startpointpq(2) = 0#
endpointpq(0) = zbjl + wide#: endpointpq(1) = zxxsp - nj#: endpointpq(2) = 0#
Set pq = acadapp.ActiveDocument.ModelSpace.AddLine(startpointpq, endpointpq)


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

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 = acLnWt030

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 = acLnWt030







'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''填充
Dim hatchobj1 As AcadHatch

patterntype = 0
patternname = "ANSI31"
bassociativity = True

Set hatchobj1 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)
'''''''''''''''''''''''''''''''''''''''''''''''''上
Dim plineobj1 As AcadLWPolyline
Dim points91(0 To 9) As Double

points91(0) = zbjl: points91(1) = zxxsp + nj
points91(2) = zbjl + wide: points91(3) = zxxsp + nj
points91(4) = zbjl + wide: points91(5) = zxxsp + crf
points91(6) = zbjl: points91(7) = zxxsp + crf
points91(8) = zbjl: points91(9) = zxxsp + nj

Set plineobj1 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points91)
Dim outerloop1(0 To 0) As AcadEntity
Set outerloop1(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points91)

hatchobj1.AppendOuterLoop (outerloop1)
hatchobj1.Evaluate

'''''''''''''''''''''''''''''''''''''''''''''''''''下
Dim hatchobj2 As AcadHatch
Set hatchobj2 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)
Dim plineobj2 As AcadLWPolyline
Dim points92(0 To 9) As Double

points92(0) = zbjl: points92(1) = zxxsp - nj
points92(2) = zbjl + wide: points92(3) = zxxsp - nj
points92(4) = zbjl + wide: points92(5) = zxxsp - crf
points92(6) = zbjl: points92(7) = zxxsp - crf
points92(8) = zbjl: points92(9) = zxxsp - nj

Set plineobj2 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points92)
Dim outerloop2(0 To 0) As AcadEntity
Set outerloop2(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points92)

hatchobj2.AppendOuterLoop (outerloop2)
hatchobj2.Evaluate








'画中心线。
'画分度圆

''定义线型（中心线）

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)


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

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

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


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


Dim zxx4j As AcadLine '画分度圆
Dim startpoint004j(0 To 2) As Double '
Dim endpoint004j(0 To 2) As Double
startpoint004j(0) = zbjl - 10#: startpoint004j(1) = zxxsp + cr#: startpoint004j(2) = 0#
endpoint004j(0) = zbjl + wide + 10#: endpoint004j(1) = zxxsp + cr#: endpoint004j(2) = 0#
Set zxx4j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint004j, endpoint004j)


Dim zxx5j As AcadLine '画分度圆
Dim startpoint005j(0 To 2) As Double '
Dim endpoint005j(0 To 2) As Double
startpoint005j(0) = zbjl - 10#: startpoint005j(1) = zxxsp - cr#: startpoint005j(2) = 0#
endpoint005j(0) = zbjl + wide + 10#: endpoint005j(1) = zxxsp - cr#: endpoint005j(2) = 0#
Set zxx5j = acadapp.ActiveDocument.ModelSpace.AddLine(startpoint005j, endpoint005j)

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



End Sub

Private Sub Command3_Click()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''小齿轮绘图

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  '齿数，模数，压力角，分度圆r，基圆r，齿顶圆r，齿底圆r

cz = Text2.Text                   '小齿轮齿数
cm = Text3.Text                   '模数
ca = Text4.Text * 3.1415926 / 180 '压力角
czd = Text1.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        'A0
tzc = 1189
tzg = 841
e = 20
End If

If Option2.Value = True Then        'A1
tzc = 841
tzg = 594
e = 20
End If
 
If Option3.Value = True Then        'A2
tzc = 594
tzg = 420
e = 10
End If

If Option4.Value = True Then        'A3
tzc = 420
tzg = 297