求教vba 生成齿轮的程序

nn136 · 发表于 2009-11-9 17:18:10

经典图书

Private Sub CommandButton1_Click()

Dim points(9) As Double
Dim CZ As Double, CM As Double, CA As Double, CRa As Double
CZ = Me.TextBox1
CM = Me.TextBox2 / 1000
CA = Me.TextBox3 * 3.141 / 180

'计算齿轮轮廓线的坐标points 和顶园坐标CRa
Call 齿轮廓线(CZ, CM, CA, points(), CRa)
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim nPtData(26) As Double
Dim vPtData As Variant
Dim swSketchSeg(1) As SldWorks.SketchSegment
Set swApp = Application.SldWorks
Set swMoldel = swApp.ActiveDoc

Set swSketchSeg(0) = swModel.CreateCircleByRadius2(0, 0, 0, CRa) '老是这行出错
swModel.InsertSketch2 True
nPtData(0) = -points(8): nPtData(1) = points(9): nPtData(2) = 0#
nPtData(3) = -points(6): nPtData(4) = points(7): nPtData(5) = 0#
nPtData(6) = -points(4): nPtData(7) = points(5): nPtData(8) = 0#
nPtData(9) = -points(2): nPtData(10) = points(3): nPtData(11) = 0#
nPtData(12) = -points(0): nPtData(13) = points(1): nPtData(14) = 0#
nPtData(15) = -points(2): nPtData(16) = points(3): nPtData(17) = 0#
nPtData(18) = -points(4): nPtData(19) = points(5): nPtData(20) = 0#
nPtData(21) = -points(6): nPtData(22) = points(7): nPtData(23) = 0#
nPtData(24) = -points(8): nPtData(25) = points(9): nPtData(26) = 0#
vPtData = nPtData
Set swSketchSeg(1) = swModel.CreateSpline(vPtData) '创建此轮轮廓线条曲线
Dim bRet As Boolean
'会支持论定圆曲线
bRet = swModel.CreateArcByCenter(0, 0, 0, points(8), points(9), 0, -points(8), points(9), 0)
swModel.InsertSketch2 True
swModel.ViewZoomtofit2 '整平显示图形
End Sub

Sub 齿轮廓线(CZ As Double, CM As Double, CA As Double, points() As Double, CRa As Double)
Dim CR As Double, CRb As Double, CRf As Double, CSb As Double, Th(3)
'------------------------------------------
CR = CM * CZ / 2 '齿轮分度圆半径
CRf = (CR - 1.25 * CM) '齿轮根圆半径
CRb = CR * Cos(CA) '齿轮基圆半径
CRa = CR + CM ' 齿轮顶圆半径
'-------------------------------------------
'齿轮基员齿厚
CSb = Cos(CA) * (3.14 * CM / 2 + CM * CZ * (Tan(CA) - (CA)))
Th(1) = (3.14 * CM * Cos(CA) - CSb) / (2 * CRb)
Th(2) = Th(1) + Tan(CA) - CA
' ACos---反余弦自定义函数
Th(3) = Th(1) + Tan(Acos(CRb / CRa)) - Acos(CRb / CRa)

'第零点
points(0) = 0: points(1) = CRf
'第一点
points(2) = CRf * Sin(Th(0)): points(3) = CRf * Cos(Th(0))
'第2点
points(4) = CRf * Sin(Th(1)): points(5) = CRf * Cos(Th(1))
'第3点
points(6) = CRf * Sin(Th(2)): points(7) = CRf * Cos(Th(2))
'第4点
points(8) = CRf * Sin(Th(3)): points(9) = CRf * Cos(Th(3))
'调整
If CRb < CRf Then
points(2) = points(6) * 0.2: points(3) = points(1) + 0.25 * CM * 0.03

points(4) = points(6) * 0.7: points(5) = points(1) + 0.25 * CM * 0.8
End If
End Sub

Function Acos(X As Double) As Double '反余弦
Dim pi As Double
pi = 4# * Atn(1#) '45度=pi/4
If Abs(X) > 1# Then
MsgBox "cosX>1,Acos(x)函数出错", 1 + 16, "警告": Exit Function
Else
If Abs(X) = 1# Then
Acos = (1# - X) * pi / 2#
Else
Acos = pi / 2 - Atn(X / Sqr(-X * X + 1))
End If
End If
End Function

Private Sub CommandButton2_Click()
End
End Sub
Private Sub UserForm_Initialize()
Me.Label1 = "齿数"
Me.Label2 = "模数"
Me.Label3 = "压力角"
Me.CommandButton1.Caption = "确定"
Me.CommandButton2.Caption = "取消"
Me.TextBox1 = 21
Me.TextBox2 = 12
Me.TextBox3 = 20
End Sub

example.rar (27.07 KB, 下载次数: 196)

3_D · 发表于 2009-11-9 17:21:38

正在学这个，呵呵

翼づ飞翔 · 发表于 2009-11-9 17:24:58

经典图书

正在用vb做这sw的开发，程序是你用宏录制的还是自己写的？

tcapple · 发表于 2009-11-9 17:26:53

想叫高手教教变位的怎么编写

erhaiwa · 发表于 2009-11-9 17:32:34

经典案例图书

看看咯

colour · 发表于 2009-11-9 17:45:01

哪位高手指点一下啊，我也遇到这个问题了

baicaibu · 发表于 2009-11-9 17:45:10

经典案例图书

高手指点！！我想画个内斜齿轮，上面的程序我改了
CR = CM * CZ / 2 '齿轮分度圆半径
CRf = (CR - 1.25 * CM) '齿轮根圆半径
CRb = CR * Cos(CA) '齿轮基圆半径
CRa = CR + CM ' 齿轮顶圆半径
这一部分，可是没办法生成内齿！！！！求高手指点！！！