Import System.Math
Dim A cadapp As AutoCAD .AcadApplication
Dim Z As Integer ,m ,Af,Beta,B,Xn As Double
Dim R, Rf, Rb, Ra As Double
Dim 毛坯As AutoCAD. Acad3Dsolid
Dim 齿槽As AutoCAD. Acad3Dsolid
Private Sub Form1—Load (ByVal sender As System .Object,ByVal e As System.EventArgs) Handles MyBase.Lode
Me.Text=”斜齿轮造型”
Me.GroupBox1. Text=” ”
Me.Labell11. Text=”齿数z”
Me.Labell12. Text=”模数m”
Me.Labell13. Text=”压力角Af”
Me.Labell14. Text=”螺旋角Beta”
Me.Labell15. Text=”齿宽B”
Me.Labell16. Text=”法向变位系数Xn”
Me.Labell17. Text=”轴向精度”
Me. TextBox1. Text=19
Me. TextBox2. Text=6
Me. TextBox3.Text=20
Me. TextBox4. Text=16
Me. TextBox5. Text=30
Me. TextBox6. Text=0.22
Me. TextBox7. Text=0.05
Me.Button1.Text=” 斜齿轮造型”
End Sub
Private Sub Button1—Click(ByVal sender As System.Object, System . EventArgs) Handles Button1—Click
e As ByVal
Call 连接AutoCAD（）
Call 斜齿轮基本参数计算（）
Call 毛坯造型（）
Call 齿槽造型（）
Call 斜齿轮造型（）
Call 删除非三维实体对象（）
End Sub
Sub斜齿轮基本参数计算（）
Z=Val (Me.TextBox1. Text)
Beta= Val (Me.TextBox4. Text)*PI/180
m= Val (Me.TextBox2. Text)
m=m/Cos(Beta) ’斜齿轮端面模数
Af = Val (Me.TextBox3. Text) *PI/180
Af = Atan(Tan(Af)/Cos(Beta)) ’斜齿轮端面压力角
B= Val (Me.TextBox5. Text)
Xn= Val (Me.TextBox6. Text)’法向变位系数
R=m*z/2’齿轮分度圆半径
Rf=(R-(1+0.25-Xn)*m*Cos(Beta)’齿轮根圆半径
Rb=R*Cos(Af)’齿轮基圆半径
Ra=R+m*Cos(Beta)*(1+Xn)”齿轮顶圆半径
End Sub
Sub 毛坯造型（）
，根据经验公式进行毛坯造型
Dim center (2) As Double
Center (0) =0.0# : Center (1) =0.0# : Center (2)=B / 2
毛坯=Acadapp.ActiveDocument.ModelSpace.AddCylinder(Center,Ra,B)
‘轴孔
Dim solidobj2 As AutoCAD.Acad3Dsolid
Dim D0 As Double
D0 = Ra / 2
solidobj2=
Acadapp.ActiveDocument.ModelSpace.AddCylinder(Center,D0/2,B*1.1)
毛坯。Boolean(AutoCAD.AcBooleanType.acSubtraction, solidobj2)
‘键
Dim boxObj As AutoCAD. Acad3Dsolid
Dim length As Double , with As Double,height As Doublea
Center (0) =0: Center (1) ==D0 / 2: Center (2) =0
Length
Acadapp.ActiveDocument.ModelSpace.AddBox(Center,length,width,height)
=
毛坯.Boolean(AutoCAD. .AcBooleanType.acSubtraction,box0bj)
毛坯.Color = AutoCAD.ACAD-COLOR.acBlue
End Sub
Sub 齿槽造型（）
根据斜齿轮端面参数计算
根据渐开线公式，计算斜齿轮端面渐开线上各点坐标
Dim Sb，th（3）
Sb=Cos(Af)*(PI*m/2+m*z*(Tan(Af)-(Af)))’齿轮基圆齿厚
Th(1) =(PI*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 cuives(5) As AutoCAD.AcadEntity
Dim points0(5) As Double
Dim points0(8) As Double
Dim points0(5) As Double
points0(0)=0; points0(1)=Rf’第0点
points0(2)=Rf*Sin(th(0)) : points0(3)= Rf*cos(th(0)) 第1点
points0(4)=Rb*Sin(th(1)) : points0(5)= Rf*cos(th(1)) 第2点
Dim startTan(2) As Double
Dim endtan(2) As Double
startTan(0) = 0：startTan(1)=0：startTan(2)=0
endTan(0) = 0: endTan(1)=0: endTan(2)=0
points1(0) = points0(4): points0(1)= points0(5): points1(2)=0’第2点
points1(3)=R*Sin（th(2)）: points1(4)=R*Cos(th(2)): points1(5)=0第3点
points1(6)=Ra*Sin（th(3)）: points1(7)=R*Cos(th(3)): points1(8)=0第4点
points2(0)= points1(6)= points2(1)= points1(7)第4点
points2(2)= points1(6)= points2(3)= points1(7)+2.25*m第5点
points2(4)= 0:points2(5)= points2(3)’第6点
‘当基圆小雨根圆，调整第1，第2点坐标，得到近似值
If Rb Points0(2) = points1(3)*0.2: points0(3)= points0(1)+0.25*m*0.03’第1点Points0(4) = points1(3)*0.7: points0(3)= points0(5)+0.25*m*0.8’第2点
Points1(0) = points0(4): points1(1)= points0(5)：points1(2)=0’第1点
End If
‘创建右部线段
Curves(0) = Acadapp.ActiveDocument.ModelSpace.AddCylinder(Points0) ‘由0,1,2点组成
Curves(0).SetBulge(1,0.2) ‘第一点凸度为0.2
‘创建样条曲线
Curves(0).Acadapp.ActiveDocument.ModelSpace.Addline(Points1 ,startTa
n,endTen) ‘由2,3,4点组成
Curves(2).Acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(Points2 ) ‘由4,5,6点组成
‘镜像右部线段，得到左部线段
Dim points1(2) As Double
Dim points1(2) As Double
points1(0) =0：points1(1) =0：points1(2) =0
points2(0) =0：points2(1) =1：points2(2) =0
curves(3)=curves(2).Mirror(Point1, Point2)
curves(4)=curves(1).Mirror(Point1, Point2)
curves(5)=curves(0).Mirror(Point1, Point2)
‘创建面域
Dim 齿槽轮廓 As Object
齿槽轮廓 = Acadapp.ActiveDocument.ModelSpace.AddRegion（curves）
Dim solidObj As AutoCAD.Acad3Dsolid
Dim I As Ddouble
Dim startPoint(2) As Ddouble
Dim endPoint(2) As Ddouble
Dim lineObj As AutoCAD.Acadline
Dim齿槽轮廓copy As AutoCAD.AcadRegion
Dim nstep As Ddouble’轴向精度
Nstep = Val （Me.TextBox7.Txet）
For i = nstep T0 1 + nstep Step nstep
startPoint(0)=0: startPoint(1)=R: startPoint(2)=B*(i- nstep)
endPoint (0)=0: endPoint (1)=R: endPoint (2)B*i
‘拉伸路径
lineObj endPoint)
= Acadapp.ActiveDocument.ModelSpace.Addline(startPoint,
齿槽轮廓copy=齿槽轮廓(0)copy
startPoint(0)=0 startPoint(1)=R: startPoint(2)=0
齿槽轮廓copy.Move (startPoint, endPoint)
endPoint(0) = 0: endPoint(1)=0: endPoint(2):0
‘旋转
齿槽轮廓copy.Rotate (endPoint,Beta*i)
‘沿路径拉伸
If I = nstep then
齿槽= Acadapp.ActiveDocument.ModelSpace.
AddExtrudeSolidAlongPath(齿槽轮廓copy,lineObj)
End if
solidObj = Acadapp.ActiveDocument.ModelSpace.
AddExtrudeSolidAlongPath(齿槽轮廓copy,lineObj)
齿槽.Boolean(AutoCAD.AcBoolanType.acUnion,solidObj)
Next
齿槽.color = AutoCAD.ACAD—COLOR . acRed
End Sub
Sub 斜齿轮造型（）
‘环形阵列
Dim 齿槽阵列 As Object
Dim centerPoint (2) As Ddouble
centerPoint (0) = 0.0# : centerPoint (1)=0.0# centerPoint (2) =0
齿槽阵列=齿槽 .ArrayPolar (Z,2*PI, centerPoint )
‘毛坯与齿槽阵列进行布尔减运算
On Error Resume Next
Dim I As Integer
For I = 0 To Z -2
毛坯.Boolean(AutoCAD.AcBoolanType.acSubtraction, 齿槽阵列(i))
Next
毛坯Boolean(AutoCAD.AcBoolanType.acSubtraction, 齿槽).
‘改变看图方向
Dim NewDirection (2) As Ddouble
NewDirection (0) = -1 : NewDirection (1) = -1 NewDirection (2) = 1
Acadapp. ActiveDocument.ActiveViewport. Direction= NewDirection
Acadapp. ActiveDocument.ActiveViewport= Acadapp. ActiveDocument.
ActiveViewport
Acadapp.ZoomExtents（）
End Sub
Sub 删除非三维实体对象（）
On Error Resume Next
Dim returnObj As AutoCAD.AcadEntidy
For Each returnObj In Acadapp.ActiveDocument.ModelSpace.
If returnObj . ObjectName < > End Sub
Acadapp.ZoomExtents（）
End Sub
AcDb3dSolid ”Then
“
