form02.frm

锥齿轮CAD设计

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
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   '定义不同图纸的不同左右上下距离。(左)
Dim yjl As Double  '(右距离)
Dim sjl As Double  '(上距离)
Dim xjl As Double  '(下距离)

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   '图框长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 ab As AcadLine
Dim startpointab(0 To 2) As Double
Dim endpointab(0 To 2) As Double
startpointab(0) = 100#: startpointab(1) = 50#: startpointab(2) = 0#
endpointab(0) = 150#: endpointab(1) = 50#: 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) = 150#: startpointbc(1) = 50#: startpointbc(2) = 0#
endpointbc(0) = 150#: endpointbc(1) = 120#: 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) = 150#: startpointcd(1) = 120#: startpointcd(2) = 0#
endpointcd(0) = 125#: endpointcd(1) = 120#: 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) = 125#: startpointde(1) = 120#: startpointde(2) = 0#
endpointde(0) = 100#: endpointde(1) = 50#: endpointde(2) = 0#
Set de = acadapp.ActiveDocument.ModelSpace.AddLine(startpointde, endpointde)





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

''创建填充对象
Set hatchobj1 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)
Set hatchobj2 = acadapp.ActiveDocument.ModelSpace.AddHatch(patterntype, patternname, bassociativity)

Dim plineobj1 As AcadLWPolyline
Dim ps1(0 To 9) As Double

ps1(0) = 100: ps1(1) = 50
ps1(2) = 150: ps1(3) = 50
ps1(4) = 150: ps1(5) = 120
ps1(6) = 125: ps1(7) = 120
ps1(8) = 100: ps1(9) = 50

Set plineobj1 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(ps1)

Dim outerloop1(0 To 0) As AcadEntity

Set outerloop1(0) = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(ps1)

hatchobj1.AppendOuterLoop (outerloop1)






End Sub

Private Sub Command4_Click()
                                           '退出界面，退出AutoCAD，释放内存。
Unload Me
Form1.Show
acadapp.Quit
Set acadapp = Nothing

End Sub

Private Sub Command5_Click()
Text10.Text = "1、调质处理230～250HBS;" & vbCrLf & "2、倒角2×45" & "%%d。"
End Sub

Private Sub Form_Load()

'链接AutoCAD。

On Error Resume Next
Set acadapp = GetObject(, "autocad.application")
If Err Then
    Err.Clear
    Set acadapp = CreateObject("autocad.application")
    If Err Then
       MsgBox ("不能运行AutoCAD，请检查是否已安装AutoCAD！")
       Exit Sub
    End If
 End If
 acadapp.Visible = True

'给TEXT赋初值。


Text5.Text = "陈日勇"
Text6.Text = "陈日勇"
Text9.Text = "05.03.26"
Text8.Text = "锻钢"
Text7.Text = "方  芳"
End Sub