VB齿轮程序

希望做完善后再贴出来分享.

1楼的朋友能否把程式共享？ [s:23]

非常感谢！！！！！！

引用第2楼fox1107于2006-05-15 16:42发表的“”:
那麻烦你把程序传上来吧
谢谢

下了，也运行了，既然是小程序，何必用CAD库

楼主厉害

我也做过，哪天发给你看看。现在正在做内啮合圆柱齿轮的测绘程序。

用CAD库?那就是说不装cad就不行？

楼主怎么使用，可以介绍一下吗？

Private Sub Command1_Click()
On Error Resume Next
齿轮CAD.ActiveDocument.Close
齿轮CAD.Documents.Add
Dim CZ, CM, CA, CR, CRb, CRf, CRa, CSb, Umax, U, b
Dim th(3)
Dim I
CZ = Val(Me.Text1)
CM = Val(Me.Text2)
CA = Val(Me.Text3) * pi / 180
Dim NewDirection(0 To 2) As Double
NewDirection(0) = 1: NewDirection(1) = 0.5: NewDirection(2) = 0.5
齿轮CAD.ActiveDocument.ActiveViewport.Direction = NewDirection
齿轮CAD.ActiveDocument.ActiveViewport = 齿轮CAD.ActiveDocument.ActiveViewport
齿轮CAD.ActiveDocument.Layers(0).Color = acRed
齿轮CAD.ActiveDocument.SendCommand "_Shademode" + vbCr + "_G" + vbCr
CR = CM * CZ / 2
CRf = (CR - 1.25 * CM)
CRb = CR * Cos(CA)
CRa = CR + CM
Dim 齿轮3D   As Acad3DSolid
Dim centerPoint(0 To 2) As Double
centerPoint(0) = 0#: centerPoint(1) = 0#: centerPoint(2) = 0#
Dim height As Double
height = CRa / 3
Set 齿轮3D = 齿轮CAD.ActiveDocument.ModelSpace.AddCylinder(centerPoint, CRa, height)
Dim 轴孔   As Acad3DSolid
Set 轴孔 = 齿轮CAD.ActiveDocument.ModelSpace.AddCylinder(centerPoint, CRa / 3, height)
齿轮3D.Boolean acSubtraction, 轴孔
齿轮3D.Color = acBlue
ZoomAll
Dim plineObj(0) As AcadLWPolyline

CES = CM * pi / 2
th(0) = CES / CM / CZ - inv(CA) '基圆
If CRf < CRb Then
  th(1) = th(0) / 3   &#39;小径
Else
  th(1) = CES / CM / CZ - (inv(CA) - inv(argcos(CRb / CRf)))  &#39;小径
End If
th(2) = CES / CM / CZ  &#39;分度圆
th(3) = CES / CM / CZ + (inv(argcos(CRb / CRa)) - inv(CA))      &#39;大径

Dim curves(0 To 5) As AcadEntity
Dim points0(0 To 5) As Double
Dim points1(0 To 8) As Double
Dim points2(0 To 5) As Double
points0(0) = 0: points0(1) = CRf
points0(2) = CRf * Sin(th(1)): points0(3) = CRf * Cos(th(1))
points0(4) = CRb * Sin(th(0)): points0(5) = CRb * Cos(th(0))

Dim startTan(0 To 2)   As Double
Dim endTan(0 To 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) = points0(0)
points1(3) = CR * Sin(th(2)): points1(4) = CR * Cos(th(2)): points1(5) = 0
points1(6) = CRa * Sin(th(3)): points1(7) = CRa * Cos(th(3)): points1(8) = 0

points2(0) = points1(6): points2(1) = points1(7)
points2(2) = points1(6): points2(3) = points1(7) + 20
points2(4) = 0: points2(5) = points2(3)

Set curves(0) = 齿轮CAD.ActiveDocument.ModelSpace.AddLightWeightPolyline(points0)
&#39;curves(0).SetBulge , 0, 0.2
Set curves(1) = 齿轮CAD.ActiveDocument.ModelSpace.AddSpline(points1, startTan, endTan)
Set curves(2) = 齿轮CAD.ActiveDocument.ModelSpace.AddLightWeightPolyline(points2)
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 0: point2(1) = 1: point2(2) = 0
Set curves(3) = curves(2).Mirror(point1, point2)
Set curves(4) = curves(1).Mirror(point1, point2)
Set curves(5) = curves(0).Mirror(point1, point2)
Dim 刀具  As Variant
刀具 = 齿轮CAD.ActiveDocument.ModelSpace.AddRegion(curves)
Dim axisPt(0 To 2)  As Double
Dim axisDir(0 To 2)  As Double
Dim angie As Double
axisPt(0) = 0: axisPt(1) = points2(5) + 2 * CM: axisPt(2) = 0
axisDir(0) = 1: axisDir(1) = 0: axisDir(2) = 0
angie = 6.29
Dim 刀具3D As Acad3DSolid
Set 刀具3D = 齿轮CAD.ActiveDocument.ModelSpace.AddRevolvedSolid(刀具(0), axisPt, axisDir, angie)
ZoomAll
Dim boxObj As Acad3DSolid
Dim center(0 To 2) As Double
Dim taperAngle As Double
taperAngle = 0
center(0) = 0: center(1) = CRf: center(2) = 0
Set boxObj = 齿轮CAD.ActiveDocument.ModelSpace.AddBox(center, CM / 2, 4 * CM, points2(0) * 2)
Dim retObj  As Variant
retObj = boxObj.ArrayPolar(20, 6.28, 刀具3D.Centroid)
For I = 0 To 20 - 2
retObj(I).Rotate3D center, centerPoint, pi / 2
retObj(I).Update
刀具3D.Boolean acSubtraction, retObj(I)
Next I
boxObj.Rotate3D center, centerPoint, pi / 2
刀具3D.Boolean acSubtraction, boxObj


Dim 刀具Bool As Acad3DSolid
Set 刀具Bool = 齿轮CAD.ActiveDocument.ModelSpace.AddExtrudedSolid(刀具(0), height, taperAngle)
axisPt(0) = 刀具Bool.Centroid(0)
axisPt(1) = 刀具Bool.Centroid(1)
axisPt(2) = 0
刀具Bool.Move 刀具Bool.Centroid, axisPt
刀具Bool.Visible = False
axisPt(0) = 刀具3D.Centroid(0) + 10
axisPt(1) = 刀具3D.Centroid(1)
axisPt(2) = 刀具3D.Centroid(2)
point1(0) = 刀具3D.Centroid(0)
point1(1) = 刀具3D.Centroid(1)
point1(2) = 刀具3D.Centroid(2) + height
&#39;刀具Bool.Move 刀具Bool.Centroid, point1

Dim 刀具复制 As Acad3DSolid
Dim k
I = 0
Dim 刀具3DZ坐标 As Double
刀具3DZ坐标 = 刀具3D.Centroid(2)
Do Until I > 360
For k = 刀具3DZ坐标 To 刀具3DZ坐标 - height Step -height / 3
point1(2) = k
刀具3D.Move 刀具3D.Centroid, point1
刀具3D.Update
axisPt(2) = 刀具3D.Centroid(2)
刀具3D.Rotate3D 刀具3D.Centroid, axisPt, 360 / 30 * pi / 180
刀具3D.Update
Next k
Set 刀具复制 = 刀具Bool.Copy
齿轮3D.Boolean acSubtraction, 刀具复制
刀具3D.Update
point1(2) = point1(2) + height
刀具3D.Move 刀具3D.Centroid, point1
刀具3D.Update
齿轮3D.Rotate centerPoint, -360 / CZ * pi / 180
齿轮3D.Color = acBlue
刀具3D.Update
I = 360 / CZ + I
Loop
End Sub
****************************************************************
Public Const pi As Double = 3.14159265358979


Public Function argsin(b)
Dim x0 As Double, ee As Double, eee As Double
x0 = 0
eee = 1000
Do
fx = Sin(x0) - b
dfx = Cos(x0)
x0 = x0 - (Sin(x0) - b) / Cos(x0)
ee = Abs(fx / dfx)
If ee > eee Then error1 = 1: Exit Function
eee = ee
Loop While ee > 0.0000001
argsin = x0


End Function


Public Function argcos(b)
Dim x0 As Double
x0 = pi / 2 - argsin(b)
argcos = x0
End Function


Public Function inv(b)
Dim x0 As Double
x0 = Tan(b) - b
inv = x0
End Function


Public Function arginv(b)
Dim x0 As Double, ee As Double
x0 = 0.8
eee = 1000
Do
fx = Tan(x0) - x0 - b
dfx = Tan(x0) * Tan(x0)
x0 = x0 - fx / dfx
ee = Abs(fx / dfx)
If ee > eee Then error1 = 1: Exit Function
eee = ee
Loop While ee > 0.000001
arginv = x0
End Function