基于autocad的齿轮参数化源程序

圣歌 · 发表于 2011-5-25 11:34:51

Imports System.Math
Public Class Form1
Dim AcadApp As AutoCAD.AcadApplication
Dim 刀具 As Object
Dim Da, D0, D1, D2, D3, D4, n1, B, C As Double
Dim Z, m, Af As Double
Const Pi = 3.141592
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
      Me.Text = "齿轮结构参数化三维造型"
      Me.GroupBox1.Text = ""
      Me.Label1.Text = "齿数Z"
      Me.Label2.Text = "模数m"
      Me.Label3.Text = "压力角Af"
      Me.Label4.Text = "轴径D4"
      Me.Label5.Text = "齿宽B"
      Me.Label6.Text = "D0"
      Me.Label7.Text = "D3"
      Me.TextBox1.Text = 40
      Me.TextBox2.Text = 6
      Me.TextBox3.Text = 20
      Me.TextBox4.Text = CInt(Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) * 0.3)
      D4 = Val(Me.TextBox4.Text)
      Me.TextBox5.Text = CInt(1.2 * Val(Me.TextBox4.Text))
      Da = Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) + 2 * Val(Me.TextBox2.Text)
      Me.TextBox6.Text = Da - 12 * Val(Me.TextBox2.Text)
      Me.TextBox7.Text = 1.6 * D4
      Me.CheckBox1.Text = "画腹板孔"
      Me.CheckBox1.Checked = True
      Me.Button1.Text = "齿轮结构造型"
      Me.Button2.Text = "结束"
End Sub
Sub 连接AutoCAD()
      On Error Resume Next
      AcadApp = GetObject(, "AutoCAD.Application")
      If Err.Number Then
         Err.Clear()
         AcadApp = CreateObject("AutoCAD.Application")
         If Err.Number Then
            MsgBox("不能运行AutoCAD，请检查是否安装了AutoCAD")
            Exit Sub
         End If
      End If
      AcadApp.Visible = True '界面可视
      AcadApp.WindowState = AutoCAD.AcWindowState.acMax '界面最大化
      AppActivate(AcadApp.Caption) '显示AutoCAD界面
End Sub
Sub 齿轮刀具()
      Dim R, Rf, Rb, Ra As Single
      R = m * Z / 2
      Rf = (R - 1.25 * m)
      Rb = R * Cos(Af)
      Ra = R + m
      Dim Sb, th(3)
      Sb = Cos(Af) * (3.14 * m / 2 + m * Z * (Tan(Af) - (Af)))
      th(1) = (3.14 * m * Cos(Af) - Sb) / (2 * Rb)
      th(0) = th(1) / 3
      th(2) = th(1) + Tan(Af) - Af
      th(3) = th(1) + Tan(Acos(Rb / Ra)) - Acos(Rb / Ra)
      Dim curves(5) As AutoCAD.AcadEntity
      Dim points0(5) As Double
      Dim points1(8) As Double
      Dim points2(5) As Double
      points0(0) = 0 : points0(1) = Rf
      points0(2) = Rf * Sin(th(0)) : points0(3) = Rf * Cos(th(0))
      points0(4) = Rb * Sin(th(1)) : points0(5) = Rb * Cos(th(1))
      Dim startTan(2) As Double
      Dim endTan(2) As Double
      startTan(0) = 0 : startTan(1) = 0 : startTan(2) = 0
      endTan(0) = 0.5 : endTan(1) = 0.5 : endTan(2) = 0
      points1(0) = points0(4) : points1(1) = points0(5) : points1(2) = 0
      points1(3) = R * Sin(th(2)) : points1(4) = R * Cos(th(2)) : points1(5) = 0
      points1(6) = Ra * Sin(th(3)) : points1(7) = Ra * Cos(th(3)) : points1(8) = 0
      points2(0) = points1(6) : points2(1) = points1(7)
      points2(2) = points1(6) : points2(3) = points1(7) + 2.25 * m
      points2(4) = 0 : points2(5) = points2(3)
      If Rb < Rf Then
         points0(2) = points1(3) * 0.2 : points0(3) = points0(1) + 0.25 * m * 0.03
         points0(4) = points1(3) * 0.7 : points0(5) = points0(1) + 0.25 * m * 0.8
         points1(0) = points0(4) : points1(1) = points0(5) : points1(2) = 0
      End If
      curves(0) = AcadApp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points0)
      curves(0).SetBulge(1, 0.2)
      curves(1) = AcadApp.ActiveDocument.ModelSpace.AddSpline(points1, startTan, endTan)
      curves(2) = AcadApp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points2)
      Dim point1(2) As Double
      Dim point2(2) As Double
      point1(0) = 0 : point1(1) = 0 : point1(2) = 0
      point2(0) = 0 : point2(1) = 1 : point2(2) = 0
      curves(3) = curves(2).Mirror(point1, point2)
      curves(4) = curves(1).Mirror(point1, point2)
      curves(5) = curves(0).Mirror(point1, point2)
      刀具 = AcadApp.ActiveDocument.ModelSpace.AddRegion(curves)
      Dim taperAngle As Double
      taperAngle = 0
      Dim solidObj As AutoCAD.Acad3DSolid
      solidObj = AcadApp.ActiveDocument.ModelSpace.AddExtrudedSolid(刀具(0), B * 1.1, taperAngle)
      Dim center(2) As Double
      center(0) = 0 : center(1) = solidObj.Centroid(1) : center(2) = 0
      solidObj.Move(solidObj.Centroid, center)
      Dim basePnt(2) As Double
      basePnt(0) = 0 : basePnt(1) = 0 : basePnt(2) = 0.0#
      刀具 = solidObj.ArrayPolar(Z + 1, 2 * Pi, basePnt)
End Sub
Private Sub TextBox1_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TextBox1.TextChanged, TextBox2.TextChanged
      Me.TextBox4.Text = CInt(Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) * 0.3)
      D4 = Val(Me.TextBox4.Text)
      Me.TextBox5.Text = CInt(1.2 * Val(Me.TextBox4.Text))
      Da = Val(Me.TextBox1.Text) * Val(Me.TextBox2.Text) + 2 * Val(Me.TextBox2.Text)
      Me.TextBox6.Text = Da - 12 * Val(Me.TextBox2.Text)
      Me.TextBox7.Text = 1.6 * D4
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
      Call 连接AutoCAD()
      Dim entry As AutoCAD.AcadEntity
      For Each entry In AcadApp.ActiveDocument.ModelSpace
         entry.Delete()

		自动登录	找回密码
密码			注册会员