齿轮外形程序如何做成面域？？？－－－－急！～急！

yipinbing

下面是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

mccad

1.对象炸开后要把原图块删除，这一点程序的做法与实际画图不图。
2.你所绘制的图形中，齿根圆与齿轮廓不相交，所以形成不了封闭的图形，无法转换为面域。

yipinbing

十分感谢大哥帮忙！！！


                         程序画出图后在模型中，         使用 工具－－>查询－－>点坐标                         查看齿根圆与齿廓相交的两段线的端点坐标相同，应该认为它们是相交的吧。


                         另外，当齿数较少时，如10个左右。用程序画出图以后，再在模型里用鼠标操作创建面域就能成功！小弟实在不知为什么？恳请哪位大哥再帮忙看看！

mccad

这关键就是计算精度的问题。所以建议你先完成圆弧的建模，然后在生成样条曲线时的起点终点使用原来圆弧的终点坐标，而不要再计算，这样才能保证精度。
原因，生成圆弧是使用半径和角度来生成，所以最后出来的两个端点坐标与计算的样条线端点坐标有些差异。

yipinbing

谢谢了！～


我更改了思路，先画一个齿，打散，作面域，成功了。但是块删了，打散后的东东不知如何删去。一个齿的面域生成后，我把它画成齿轮形状了，鼠标操作布尔合并成功。但不知如何程序实现，望老大赐教！～

bjjob1

我用vba做了两个面域，不能进行布尔运算，头都大了