form022.frm

锥齿轮CAD设计

      Caption         =   "绘    图："
      Height          =   180
      Left            =   840
      TabIndex        =   34
      Top             =   7020
      Width           =   900
   End
   Begin VB.Label Label10 
      AutoSize        =   -1  'True
      Caption         =   "审    核："
      Height          =   180
      Left            =   840
      TabIndex        =   33
      Top             =   7440
      Width           =   900
   End
   Begin VB.Label Label11 
      AutoSize        =   -1  'True
      Caption         =   "材    料："
      Height          =   180
      Left            =   840
      TabIndex        =   32
      Top             =   7860
      Width           =   900
   End
   Begin VB.Label Label12 
      AutoSize        =   -1  'True
      Caption         =   "日    期："
      Height          =   180
      Left            =   840
      TabIndex        =   31
      Top             =   8280
      Width           =   900
   End
   Begin VB.Label Label13 
      AutoSize        =   -1  'True
      Caption         =   "4.确定零件图比例："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   3840
      TabIndex        =   30
      Top             =   480
      Width           =   2040
   End
   Begin VB.Label Label14 
      AutoSize        =   -1  'True
      Caption         =   "5.填写技术条件："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   3840
      TabIndex        =   29
      Top             =   3600
      Width           =   1815
   End
   Begin VB.Label Label15 
      AutoSize        =   -1  'True
      BackColor       =   &H00FFFFFF&
      BackStyle       =   0  'Transparent
      Caption         =   "o"
      Height          =   180
      Index           =   1
      Left            =   3360
      TabIndex        =   28
      Top             =   2400
      Width           =   90
   End
End
Attribute VB_Name = "Form022"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Private Sub Command3_Click()
If d4 < 6 Then
  b = 2: c = 2: t = 1
  End If
  
  If d4 > 6 And d4 <= 8 Then
  b = 2: c = 2: t = 1
  End If
  
  If d4 > 8 And d4 <= 10 Then
  b = 3: c = 3: t = 1.4
  End If
  
  If d4 > 10 And d4 <= 12 Then
  b = 4: c = 4: t = 1.8
  End If
  
  If d4 > 12 And d4 <= 17 Then
  b = 5: c = 5: t = 2.3
  End If
  
  If d4 > 17 And d4 <= 22 Then
  b = 6: c = 6: t = 2.8
  End If
  
  If d4 > 22 And d4 <= 30 Then
  b = 8: c = 7: t = 3.3
  End If
  
  If d4 > 30 And d4 <= 38 Then
  b = 10: c = 8: t = 3.3
  End If
  
  If d4 > 38 And d4 <= 44 Then
  b = 12: c = 8: t = 3.3
  End If
  
  If d4 > 44 And d4 <= 50 Then
  b = 14: c = 9: t = 3.8
  End If
  
  If d4 > 50 And d4 <= 58 Then
  b = 16: c = 10: t = 4.3
  End If
  
  If d4 > 58 And d4 <= 65 Then
  b = 18: c = 11: t = 4.4
  End If
  
  If d4 > 65 And d4 <= 75 Then
  b = 20: c = 12: t = 4.9
  End If
  
  If d4 > 75 And d4 <= 85 Then
  b = 22: c = 14: t = 5.4
  End If
  
  If d4 > 85 And d4 <= 95 Then
  b = 25: c = 14: t = 5.4
  End If
  
  If d4 > 95 And d4 <= 110 Then
  b = 28: c = 16: t = 6.4
  End If
  
  If d4 > 110 And d4 <= 130 Then
  b = 32: c = 18: t = 8.4
  End If
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
                                                   '画标题栏(粗细实线）。

''粗实线部分。

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)



                                                 '''''''''''标题栏（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#