|
|
下面是vba一个画齿轮的程序，哪位大哥愿意看看？请大哥帮忙把它做成面域。另外当齿数较大时绘出的图就不像样子了，能否帮忙改改？？小弟在此先谢谢了！！
Public mnumber As Double '模数
Public znumber As Integer '齿数
Public aangle As Double '压力角
Public ha As Double '顶高系数
Public c As Double '顶隙系数
Public xscale As Double, yscale As Double
Public Sub draw_wheel()
'输入参数
mnumber = 3
znumber = 20
aangle = 20
ha = 1
c = 0.25
'如果模数或齿数有一项为0，则退出程序
If mnumber = 0 Or znumber = 0 Then
Exit Sub
End If
'将标准压力角换算成弧度
aangle = aangle * 3.1415926 / 180
'----------------------------------------
'一个齿轮在分度圆上的一些尺寸计算
Dim bangle As Double
Dim x1 As Variant, x2 As Variant
Dim y1 As Variant, y2 As Variant
bangle = 3.1415926 / 2 / znumber
'求分度圆玉左齿廓的交点
x1 = -(mnumber * znumber * Sin(bangle)) / 2
y1 = (mnumber * znumber * Cos(bangle)) / 2
'求分度圆与右齿廓的交点
x2 = (mnumber * znumber * Sin(bangle)) / 2
y2 = y1
'一个齿轮在基圆上的一些尺寸计算
Dim bbangle As Double
Dim inv_a As Double
Dim xb1 As Variant, yb1 As Variant
Dim xb2 As Variant, yb2 As Variant
inv_a = Tan(aangle) - aangle
bbangle = 3.1415926 / 2 / znumber + inv_a
' 求基圆与左齿廓的交点
xb1 = -((mnumber * znumber * Cos(aangle) * Sin(bbangle)) / 2)
yb1 = (mnumber * znumber * Cos(aangle) * Cos(bbangle)) / 2
'求基圆与右齿廓的交点
xb2 = (mnumber * znumber * Cos(aangle) * Sin(bbangle)) / 2
yb2 = yb1
'一个齿在顶圆上的一些尺寸计算
Dim aaangle As Double
Dim baangle As Double
Dim inv_aa As Double
Dim xa1 As Variant, ya1 As Variant
Dim xa2 As Variant, ya2 As Variant
Dim a1 As Double
a1 = (((znumber + 2 * ha) ^ 2) / (znumber * Cos(aangle)) ^ 2) - 1
inv_aa = Sqr(a1)
aaangle = Atn(Sqr(a1))
inv_aa = inv_aa - aaangle
baangle = 3.1415926 / (2 * znumber) - (inv_aa - inv_a)
'求顶圆与左齿廓的交点
xa1 = -(znumber + 2 * ha) * mnumber * Sin(baangle) / 2
ya1 = (znumber + 2 * ha) * mnumber * Cos(baangle) / 2
'求顶圆与右齿廓的交点
xa2 = (znumber + 2 * ha) * mnumber * Sin(baangle) / 2
ya2 = ya1
'一个轮齿顶圆中点的坐标
Dim xaz As Variant, yaz As Variant
xaz = 0
yaz = (znumber + 2 * ha) * mnumber / 2
'-----------------------------------------------------------------
'新建图纸
Dim appObj As AcadApplication
Dim dwgFile As AcadDocument
Set appObj = ThisDrawing.Application
Set dwgFile = appObj.Documents.Add
'------------------------------------------------------------------------
'定义一个轮齿图块
Dim blockobj As AcadBlock
Dim inspnt(0 To 2) As Double
Dim allent As AcadEntity
Dim blkref As AcadBlockReference
Dim blkcount As Integer
Dim blkname As String
' 判断在模型空间已有的齿廓图块数量
For Each allent In ThisDrawing.ModelSpace
If StrComp(allent.EntityName, "acdbblockreference", 1) = 0 Then
Set blkref = allent
If StrComp(Left(blkref.Name, 7), "blkgear", 1) = 0 Then
blkcount = blkcount + 1
End If
End If
Next
blkcount = blkcount + 1
'创建齿廓图块
inspnt(0) = 0
inspnt(1) = 0
inspnt(2) = 0
blkname = "blkgear" & blkcount
Set blockobj = ThisDrawing.Blocks.Add(inspnt, blkname)
'--------------------------------------------------------------------
'准备画齿廓
Dim stan(0 To 2) As Double
Dim etan(0 To 2) As Double
Dim fitpnts(0 To 8) As Double
Dim splinel As AcadSpline
Dim spliner As AcadSpline
stan(0) = 0
stan(1) = 0
stan(2) = 0
etan(0) = 0
etan(1) = 0
etan(2) = 0
fitpnts(0) = xb1
fitpnts(1) = yb1
fitpnts(2) = 0
fitpnts(3) = x1
fitpnts(4) = y1
fitpnts(5) = 0
fitpnts(6) = xa1
fitpnts(7) = ya1
fitpnts(8) = 0
'在块中插入左齿廓
Set splinel = blockobj.AddSpline(fitpnts, stan, etan)
fitpnts(0) = xb2
fitpnts(1) = yb2
fitpnts(2) = 0
fitpnts(3) = x2
fitpnts(4) = y2
fitpnts(5) = 0
fitpnts(6) = xa2
fitpnts(7) = ya2
fitpnts(8) = 0
'在块中插入右齿廓
Set spliner = blockobj.AddSpline(fitpnts, stan, etan)
'---------------------------------------------------------------------
'画齿顶圆弧
Dim ra As Double
Dim sang As Double, eang As Double
Dim arcobj As AcadArc
'求顶圆的半径
ra = (znumber + 2 * ha) * mnumber / 2
sang = 3.1415926 / 2 - baangle
eang = 3.1415926 / 2 + baangle
'注意圆心要使用块的插入点
Set arcobj = blockobj.AddArc(inspnt, ra, sang, eang)
'-----------------------------------------------------------------
'画齿根过渡圆弧
Dim zangle As Double
Dim aveang As Double
Dim rf As Double
Dim gd_x1 As Double, gd_y1 As Double
Dim poly_arc As AcadLWPolyline
Dim points(0 To 3) As Double
'求出每半个齿间距对应的角度
zangle = (360 / znumber / 2) * (3.1415926 / 180)
'求过渡圆弧和根圆接触点到齿轮中心连线与垂直轴的夹角
aveang = (bbangle + zangle) / 2
'求根圆的半径
rf = (znumber - 2 * ha - 2 * c) * mnumber / 2
'过渡圆弧与根圆接触点的坐标
gd_x1 = rf * Sin(aveang)
gd_y1 = rf * Cos(aveang)
'在基圆与齿廓的交点和根圆与过渡圆弧的接触点创建多义线
points(0) = xb2
points(1) = yb2
points(2) = gd_x1
points(3) = gd_y1
Set poly_arc = blockobj.AddLightWeightPolyline(points)
'将多义线变成圆弧
poly_arc.SetBulge 0, 0.2
poly_arc.Update
'-----------------------------------------------------------------------
'插入齿根圆弧段
Dim arcfobj As AcadArc
sang = 3.1415926 / 2 - zangle
eang = 3.1415926 / 2 - aveang
'注意圆心要使用块的插入点
Set arcfobj = blockobj.AddArc(inspnt, rf, sang, eang)
'----------------------------------------------------------------
'镜像过渡圆弧和齿根圆弧
Dim mirpnt1(0 To 2) As Double
Dim mirpnt2(0 To 2) As Double
Dim poly_arc1 As AcadLWPolyline
Dim arcfobj1 As AcadArc
'建立镜像轴
mirpnt1(0) = xaz
mirpnt1(1) = yaz
mirpnt1(2) = 0
mirpnt2(0) = 0
mirpnt2(1) = 0
mirpnt2(2) = 0
'镜像过渡圆弧段
Set poly_arc1 = poly_arc.Mirror(mirpnt1, mirpnt2)
'镜像齿根圆弧段
Set arcfobj1 = arcfobj.Mirror(mirpnt1, mirpnt2)
'--------------------------------------------------------------
'准备插入齿廓
Dim blkrefobj As AcadBlockReference
Dim insertpnt As Variant
Dim rotangle As Double
Dim i As Integer
Dim a(0 To 2) As Double
a(0) = 300
a(1) = 300
a(2) = 0
insertpnt = a
'预设x和y轴的比例因子
xscale = 1
yscale = 1
On Error Resume Next
'根据齿数循环将齿廓插入到模型空间
For i = 0 To znumber - 1
rotangle = i * (360 / znumber) * 3.1415926 / 180
Set blockrefobj = ThisDrawing.ModelSpace.InsertBlock(insertpnt, blkname, xscale, yscale, 1#, rotangle)
Dim expobj As Variant
expobj = blockrefobj.Explode
Next
ZoomAll
End Sub
|
|
置顶卡
