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

minikal

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

zhdx

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

程序三：这个是从网上“粜”来的@_@ 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

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

minikal

谢谢!!

juanjuanzhu

你的程序不全，运行的时候没有发现有几个函数未定义吗？？在书上这几个函数没有给出来，但是光盘里有的.你看看吧。

baoge81408

他妈有病，要发就发全嘛，想做好事就不要讨挨骂

xinglee

可与QQ:278410209联系.

qqqqqqqqqqqqqqq

楼主弄的咋样了，我的是一样的课题，有能够运行的程序，但没有窗体，相互交流下，ok？