[VBA]有偿求做螺栓参数化设计~~~

minikal 发表于 2005-6-5 12:01:00

有偿求做螺栓参数化设计~~~

zhdx 发表于 2005-6-6 13:55:00

楼上的兄弟是做毕业设计呢吧，我也是。。。。我弄了好多资料，还有请人帮忙弄了三个螺栓的程序，可是问题是现在程序的语言没什么错误了，可是就是出不来图象。。。。。。现在我先给你发个程序，希望我们能够共同探讨。。。程序如下：

main (thisdrawing)

Public Sub m(d, k, e, s, r, f, b, c, dw) Dim sysOSMODE As Integer sysOSMODE = thisdrawing.GetVariable("OSMODE") thisdrawing.SetVariable "OSMODE", 0 thisdrawing.Utility.InitializeUserInput 32 On Error Resume Next mp = thisdrawing.Utility.GetPoint np = thisdrawing.Utility.GetPoint l = thisdrawing.Utility.GetDistance rotsita = thisdrawing.Utility.GetAngle If s >= l Then s = l - 2# * f End If

thisdrawing.sentcommand ("_polygon" & vbCr & "6" & vbCr & mpstr & vbCr & "c" & vbCr & crad & vbCr) dx = np(0) dx1 = dx0 - k dx2 = ((e / 2# - s / 2#) / 1.732 + dxo) - k dx3 = (1.5 - 1.141) * d + dx0 - k dx5 = dx0 + r + c dx6 = dx0 - b + l - d / 5# + c dx7 = dx0 + l - b + c dx8 = dx0 + l - f + c dx9 = dx0 + l + c dx10 = (dx1 + dx2) / 2# dx11 = dx8 + d / 10# dy0 = np(l) dy2 = dy0 + d / 2# dy3 = dy0 + e * 3 / 8 dy4 = dy0 + s / 2# dy5 = dy0 + e / 2# dy6 = dy0 + r + d / 2# dy7 = dy0 + d / 2# - f dy8 = (dy4 + dy5) / 2# dy9 = dy2 - d / 10#

utilobj.CreateTypedArray p10, vbDouble, dx1, dy0, 0 utilobj.CreateTypedArray p32, vbDouble, dx3, dx2, 1

Set la = blockobj.AddLine(p10, p14)

 Set arca = blockobj.AddArc(cetpt, ccrad, angs, ange)

For Each acadent In blockobj acadent.Mirror p10, np Next acadent

utiobj.CreateTypedArray insertpt, vbDouble, np(0), np(1), np(2)

Set blockrefobj = thisdrawing.ModelSpace.InsertBlock(insertpt, mx, 1#, 1#, 1#, 0) thisdrawing.Regen acavtiveviewport

End Sub

x = sp(0) - ep(0) y = sp(1) - ep(0) distance = spr((x * 2) + (y * 2))

Set l3 = thisdrawing.ModelSpace.AddLine(lcenptl, thisdrawing.unility.PolarPoint(lcenpt1, angel1 + 3.1414926536 / 2, 100)) Set l4 = thisdrawing.ModelSpace.AddLine(lcenpt2, thisdrawing.Utility.PolarPoint(lcenpt2, angel2 + 3.1415926536 / 2, 100)) centerpt = l4.IntersectWith(l3, acExtendBoth)

Public Sub m3() Call m(3#, 2#, 6.4, 5.3, 0.2, 0.6, 12#, 0.4, 4.6)

End Sub

程序二：

Option Explicit Const pi As Double = 3.1414926

Sub createbolt() Dim objbolt As Acad3DSolid, objcone As Acad3DSolid, objcylinder As Acad3DSolid

Dim objpline As AcadLWPolyline Dim ptcen(0 To 2) As Double ptcen(0) = 0: ptcen(1) = 0: ptcen(2) = 0 Set objpline = ADDPolygon(ptcen, 6, 7.5)

Dim objregion As AcadRegion Set objregion = pltoregion(objpline) Set objboltt = ThisDrawing.ModelSpace.AddExtrudedSolid(objregion, 8, 0) objregion Delete ' Dim pttemp(0 To 2) As Double ' pttemp(0) = 20: pttemp(1) = 0: pttemp(2) = 0 ' objboltt.Rotate3D ptcen, pttemp, -pi / 2 ' ThisDrawing.ModelSpace.AddLine ptcen, pttemp

Dim ptto(0 To 2) As Double ptto(0) = 0: ptto(1) = 0: ptto(2) = 7.5 Set objcone = ThisDrawing.ModelSpace.AddCone(ptcen, 12, 15) objcone.Move ptcen, ptto

ptto(0) = 0: ptto(1) = 0: ptto(2) = 10 Set objcylinder = ThisDrawing.ModelSpace.AddCylinder(ptcen, 15, 20) objcylinder.Move ptcen, ptto

 objcylinder.Boolean acSubtraction, objcone

objbolt.Boolean acSubtraction, objcylinder

 Dim ptarrl(0 To 61) As Double Dim i As Integer For i = 0 To 61 If i Mod 4 = 0 Then ptrrl(i) = 2 * i / 4 + 10 ElseIf i Mod 4 = 1 Then ptrrl(i) = 5 ElseIf i Mod 4 = 2 Then ptrrl(i) = 2 * (i - 2) / 4 + 10 + 1 ElseIf i Mod 4 = 3 Then ptrrl(i) = 2 End If Next i Dim objpl(0 To 1) As AcadLWPolyline Set objpl(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr1)

Dim ptarr2(0 To 9) As Double ptarr2(0) = 10: ptarr2(1) = 5: ptarr2(2) = 0: ptarr2(3) = 5 ptarr2(4) = 0: ptarr2(5) = 0: ptarr2(6) = 40: ptarr2(7) = 0 ptarr2(8) = 40: ptarr2(9) = 5 Set objpl(1) = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptarr2) Dim objregionl As Variant objregionl = ThisDrawing.ModelSpace.AddRegion(objpl) objpl(0).Delete objpl(1).Delete

 ptto(0) = 0: ptto(1) = -10: ptto(2) = 0 objregionl1(0).Rotate3D ptto, ptcen, pi, pi / 2 ptto(0) = 0: ptto(1) = 0: ptto(2) = 10 Dim objboltb As Acad3DSolid Set objboltb = ThisDrawing.ModelSpace.AddRevolvedSolid(objregionl(0), ptcen, ptto, 2 * Atn(1) * 4) objregionl(0).Delete

objboltt.Boolean acUnion, objboltb

End Sub

 Public Function pltoregion(ByVal objpline As AcadLWPolyline) As AcadRegion If objpline.Close = False Then MsgBox "多段线不闭合，无法创建面域！", vbCritical Exit Function End If

 Dim objlist(0) As AcadEntity Set objlist(0) = objpline

 Dim objregion As Variant objregion = ThisDrawing.ModelSpace.AddRegion(objlist)

objpline.Delete Set pltoregion = objregion(0) End Function

zhdx 发表于 2005-6-6 13:58:00

程序三：这个是从网上“粜”来的@_@

Public Sub m(d1, h, c, d, r, k, s, c2, dw As Double)

'设置环境参数，不设置任何捕捉 Dim sysOSMODE As Integer sysOSMODE = ThisDrawing.GetVariable("osmode") ThisDrawing.SetVariable "osmode", 0

'设置初始化用户输入状态 ThisDrawing.Utility.InitializeUserInput 32

On Error Resume Next '错误状态处理 Dim fp, sp As Variant

'捕捉用户输入点 fp = ThisDrawing.Utility.GetPoint(, "请输入螺栓前视图的中心点:") sp = ThisDrawing.Utility.GetPoint(fp, "请输入螺栓侧视图的基准点:") l = ThisDrawing.Utility.GetDistance(, "请输入螺栓长度 L:") rotsita = ThisDrawing.Utility.GetAngle(, "请输入螺栓的旋转角度<0>:")

'错误状态处理 If Err Then rotsita = 0# Err.Clear End If

'设SP点为侧图绘图基准点,xzom为X方向坐标,yzom为Y方向坐标 xzom = sp(0) + 0 yzom = sp(1) + 0

'定义AP为系列定义参数, Dim ap As Variant Dim utilObj As Object Set utilObj = ThisDrawing.Utility

utilObj.CreateTypedArray ap, vbDouble, xzom, yzom, 0 If s >= l Then s = l - 2# * k End If

hrad = d / 2#

Dim mx As String mx = "M" & CStr(Fix(d1)) & CStr(Fix(h)) & CStr(Fix(l)) mmx = mx

'绘制螺栓前视图的圆 Dim circ As AcadCircle Set circ = ThisDrawing.ModelSpace.AddCircle(fp, hrad)

'绘制螺栓前视图的六边形 Dim fpstr As String fpstr = fp(0) & "," & fp(1) & "," & fp(2) ThisDrawing.SendCommand ("_polygon" & vbCr & "6" & _ vbCr & fpstr & vbCr & "c" & vbCr & hrad & vbCr)

'**************************************************** '定义当前图层设置。 Dim flagno As Integer flagno = 0

Dim iblock As Integer iblock = ThisDrawing.Blocks.Count While (iblock > 0) If ThisDrawing.Blocks.Item(iblock - 1).Name = mx Then flagno = 1 End If iblock = iblock - 1 Wend

 If flagno = 0 Then Dim layerold As Integer layerold = ThisDrawing.GetVariable("clayer") '设置各点参数值 rr = r c40 = c / 4# ax0 = ap(0) ax1 = ax0 - h ax2 = ((c / 2# - d / 2#) / 1.732 + ax0) - h ax3 = (1.5 - 1.414) * d1 + ax0 - h ax5 = ax0 + rr + c2 ax6 = ax0 - s + l - d1 / 5# + c2 ax7 = ax0 + l - s + c2 ax8 = ax0 + l - k + c2 ax9 = ax0 + l + c2 ax10 = (ax1 + ax2) / 2# ax11 = ax8 + d1 / 10# ay0 = ap(1) ay2 = ay0 + d1 / 2# ay3 = ay0 + c * 3 / 8 ay4 = ay0 + d / 2# ay5 = ay0 + c / 2# ay6 = ay0 + r + d1 / 2# ay7 = ay0 + d1 / 2# - k ay8 = (ay4 + ay5) / 2# ay9 = ay2 - d1 / 10# ccrad = 1.5 * d1 '设置各参数点 Dim p10, p32, p13, p14, p25, p05, p06, p52, p72, p77, _ p70, p82, p80, p90, p97, p62, p02, p108, p79, p119, p1, p2 As Variant utilObj.CreateTypedArray p10, vbDouble, ax1, ay0, 0 utilObj.CreateTypedArray p32, vbDouble, ax3, ay2, 0 utilObj.CreateTypedArray p13, vbDouble, ax1, ay3, 0 utilObj.CreateTypedArray p14, vbDouble, ax1, ay4, 0 utilObj.CreateTypedArray p25, vbDouble, ax2, ay5, 0 utilObj.CreateTypedArray p05, vbDouble, ax0, ay5, 0 utilObj.CreateTypedArray p06, vbDouble, ax0 + c2, ay6, 0 utilObj.CreateTypedArray p52, vbDouble, ax5, ay2, 0 utilObj.CreateTypedArray p72, vbDouble, ax7, ay2, 0 utilObj.CreateTypedArray p77, vbDouble, ax7, ay7, 0 utilObj.CreateTypedArray p70, vbDouble, ax7, ay0, 0 utilObj.CreateTypedArray p82, vbDouble, ax8, ay2, 0 utilObj.CreateTypedArray p80, vbDouble, ax8, ay0, 0 utilObj.CreateTypedArray p90, vbDouble, ax9, ay0, 0 utilObj.CreateTypedArray p97, vbDouble, ax9, ay7, 0 utilObj.CreateTypedArray p62, vbDouble, ax6, ay2, 0 utilObj.CreateTypedArray p02, vbDouble, ax0, ay2, 0 utilObj.CreateTypedArray p108, vbDouble, ax10, ay8, 0 utilObj.CreateTypedArray p79, vbDouble, ax7, ay9, 0 utilObj.CreateTypedArray p119, vbDouble, ax11, ay9, 0 utilObj.CreateTypedArray p1, vbDouble, ax0 + c2, ay0, 0 utilObj.CreateTypedArray p2, vbDouble, ax0 + c2, ay0 + dw / 2, 0 

' 生成块

Set blockObj = ThisDrawing.Blocks.Add(ap, mx) Dim linea, lineb, linec, lined, linee, linef, lineg, lineh, linei, linej, _ linek, linep, lineq As AcadLine

'绘制螺栓侧视图的一侧各条线段 Set linea = blockObj.AddLine(p10, p14) Set lineb = blockObj.AddLine(p14, p25) Set linec = blockObj.AddLine(p25, p05) Set lined = blockObj.AddLine(p05, ap) Set linee = blockObj.AddLine(p06, ap) Set linef = blockObj.AddLine(p32, p02) Set lineg = blockObj.AddLine(p52, p82) Set lineh = blockObj.AddLine(p82, p80) Set linei = blockObj.AddLine(p82, p97) Set linej = blockObj.AddLine(p97, p90) Set linek = blockObj.AddLine(p72, p70) Set linep = blockObj.AddLine(p1, p2) Set lineq = blockObj.AddLine(p2, p05) dist = distance(p32, p10) pi = 3.1415926536 ang1 = Atn(Sqr(ccrad ^ 2 - (dist / 2#) ^ 2) * 2 / dist) ang2 = ThisDrawing.Utility.AngleFromXAxis(p32, p10) ang3 = ang1 + ang2 - 2 * pi Dim cenPt As Variant cenPt = ThisDrawing.Utility.PolarPoint(p32, ang3, ccrad) angs = ThisDrawing.Utility.AngleFromXAxis(cenPt, p32) ange = ThisDrawing.Utility.AngleFromXAxis(cenPt, p10) Dim arca As AcadArc Set arca = blockObj.AddArc(cenPt, ccrad, angs, ange) Dim arcb As AcadArc Dim cenPt2 As Variant '利用 p108, p13, p32 绘制圆弧 cenPt2 = centerPt(p108, p13, p32) arcb_ra = distance(cenPt2, p108) arcb_angs = ThisDrawing.Utility.AngleFromXAxis(cenPt2, p108) arcb_ange = ThisDrawing.Utility.AngleFromXAxis(cenPt2, p32) Set arcb = blockObj.AddArc(cenPt2, arcb_ra, arcb_angs, arcb_ange) 'arcc distc = distance(p06, p52) ang1c = Atn(Sqr(rr ^ 2 - (distc / 2#) ^ 2) * 2 / distc) ang2c = ThisDrawing.Utility.AngleFromXAxis(p06, p52) ang3c = ang1c + ang2c - 2 * pi Dim cenPt3 As Variant cenPt3 = ThisDrawing.Utility.PolarPoint(p06, ang3c, rr) arcc_angs = ThisDrawing.Utility.AngleFromXAxis(cenPt3, p06) arcc_ange = ThisDrawing.Utility.AngleFromXAxis(cenPt3, p52) '绘制螺栓侧视图的圆弧 Dim arcc As AcadArc Set arcc = blockObj.AddArc(cenPt3, rr, arcc_angs, arcc_ange) 'color 3 Dim linel, linem As AcadLine Set linel = blockObj.AddLine(p62, p79) Set linem = blockObj.AddLine(p79, p119) linel.Color = 3 linem.Color = 3 '对绘制的螺栓进行镜像 Dim acadent As AcadEntity For Each acadent In blockObj acadent.Mirror p10, ap Next acadent End If

Dim insertPt As Variant utilObj.CreateTypedArray insertPt, vbDouble, sp(0), sp(1), sp(2) Dim blockRefObj As AcadBlockReference Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertPt, mx, 1#, 1#, 1#, 0) ThisDrawing.Regen acActiveViewport 

ThisDrawing.SetVariable "osmode", sysOSMODE End Sub

zhdx 发表于 2005-6-6 14:00:00

程序发给你了，希望能够多交流交流。。。。我TMD也快死了！！！

minikal 发表于 2005-6-10 13:10:00