form01.frm

锥齿轮CAD设计

height15 = 3.5
insertionpoint15(0) = tkc - 118 + 1#: insertionpoint15(1) = 9.5: insertionpoint15(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl15 = acadapp.ActiveDocument.ModelSpace.AddText(textstring15, insertionpoint15, height15)

Dim btl16 As AcadText
Dim textstring16 As String
Dim height16 As Double
Dim insertionpoint16(0 To 2) As Double
'定义文字的高度和书写位置
textstring16 = Text9.Text
height16 = 3.5
insertionpoint16(0) = tkc - 90 + 1#: insertionpoint16(1) = 9.5: insertionpoint16(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl16 = acadapp.ActiveDocument.ModelSpace.AddText(textstring16, insertionpoint16, height16)

                                                              '''审核
Dim btl17 As AcadText
Dim textstring17 As String
Dim height17 As Double
Dim insertionpoint17(0 To 2) As Double
'定义文字的高度和书写位置
textstring17 = "审核"
height17 = 3.5
insertionpoint17(0) = tkc - 130 + 1#: insertionpoint17(1) = 1.5: insertionpoint17(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl17 = acadapp.ActiveDocument.ModelSpace.AddText(textstring17, insertionpoint17, height17)

Dim btl18 As AcadText
Dim textstring18 As String
Dim height18 As Double
Dim insertionpoint18(0 To 2) As Double
'定义文字的高度和书写位置
textstring18 = Text7.Text
height18 = 3.5
insertionpoint18(0) = tkc - 118 + 1#: insertionpoint18(1) = 1.5: insertionpoint18(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl18 = acadapp.ActiveDocument.ModelSpace.AddText(textstring18, insertionpoint18, height18)

Dim btl19 As AcadText
Dim textstring19 As String
Dim height19 As Double
Dim insertionpoint19(0 To 2) As Double
'定义文字的高度和书写位置
textstring19 = Text9.Text
height19 = 3.5
insertionpoint19(0) = tkc - 90 + 1#: insertionpoint19(1) = 1.5: insertionpoint19(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl19 = acadapp.ActiveDocument.ModelSpace.AddText(textstring19, insertionpoint19, height19)


Dim btl20 As AcadText
Dim textstring20 As String
Dim height20 As Double
Dim insertionpoint20(0 To 2) As Double
'定义文字的高度和书写位置
textstring20 = "集大机制0113班"
height20 = 5.2
insertionpoint20(0) = tkc - 65 + 3#: insertionpoint20(1) = 3.2: insertionpoint20(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set btl20 = acadapp.ActiveDocument.ModelSpace.AddText(textstring20, insertionpoint20, height20)

                             ''''''''''技术条件jstj
Dim jstj0 As AcadText
Dim textstringjstj0 As String
Dim heightjstj0 As Double
Dim insertionpointjstj0(0 To 2) As Double
'定义文字的高度和书写位置
textstringjstj0 = "技术条件："
heightjstj0 = 5.2
insertionpointjstj0(0) = tkc - 130#: insertionpointjstj0(1) = 62: insertionpointjstj0(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set jstj0 = acadapp.ActiveDocument.ModelSpace.AddText(textstringjstj0, insertionpointjstj0, heightjstj0)

Dim jstj As AcadText
Dim textstringjstj As String
Dim heightjstj As Double
Dim insertionpointjstj(0 To 2) As Double
'定义文字的高度和书写位置
textstringjstj = Text10.Text
heightjstj = 3.5
insertionpointjstj(0) = tkc - 130#: insertionpointjstj(1) = 56: insertionpointjstj(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set jstj = acadapp.ActiveDocument.ModelSpace.AddText(textstringjstj, insertionpointjstj, heightjstj)

                                  '''''''''齿轮说明框smk

Dim smk1 As AcadText
Dim textstringsmk1 As String
Dim heightsmk1 As Double
Dim insertionpointsmk1(0 To 2) As Double
'定义文字的高度和书写位置
textstringsmk1 = "模数(m)"
heightsmk1 = 3.5
insertionpointsmk1(0) = tkc - 65 + 2#: insertionpointsmk1(1) = tkg - 6: insertionpointsmk1(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set smk1 = acadapp.ActiveDocument.ModelSpace.AddText(textstringsmk1, insertionpointsmk1, heightsmk1)

Dim smk2 As AcadText
Dim textstringsmk2 As String
Dim heightsmk2 As Double
Dim insertionpointsmk2(0 To 2) As Double
'定义文字的高度和书写位置
textstringsmk2 = Text3.Text
heightsmk2 = 3.5
insertionpointsmk2(0) = tkc - 35 + 2#: insertionpointsmk2(1) = tkg - 6: insertionpointsmk2(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set smk2 = acadapp.ActiveDocument.ModelSpace.AddText(textstringsmk2, insertionpointsmk2, heightsmk2)

Dim smk3 As AcadText
Dim textstringsmk3 As String
Dim heightsmk3 As Double
Dim insertionpointsmk3(0 To 2) As Double
'定义文字的高度和书写位置
textstringsmk3 = "齿数(z)"
heightsmk3 = 3.5
insertionpointsmk3(0) = tkc - 65 + 2#: insertionpointsmk3(1) = tkg - 14: insertionpointsmk3(2) = 0#

acadapp.ActiveDocument.ActiveTextStyle = styobj2
Set smk3 = acadapp.ActiveDocument.ModelSpace.AddText(textstringsmk3, insertionpointsmk3, heightsmk3)

Dim smk4 As AcadText
Dim textstringsmk4 As String
Dim heightsmk4 As Double
Dim insertionpointsmk4(0 To 2) As Double
'定义文字的高度和书写位置
textstringsmk4 = Text1.Text
heightsmk4 = 3.5
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)


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
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#