- UID
- 235805
- 积分
- 0
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2005-3-31
- 最后登录
- 1970-1-1
|
马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？立即注册
×
求助：我在创建了几条封闭曲线，用addregion形成面后，怎么不能拉伸啊，下面是我的程序
Option Explicit
Dim ³ÝÂÖCAD As AcadApplication
Const pi As Double = 3.1415926
Private Sub Command1_Click() 'È¡Ïû¼ü
Me.Text1 = 27 'µ¶¾ß³ÝÊý
Me.Text2 = 5 'µ¶¾ßÄ£Êý
Me.Text3 = 20 'µ¶¾ßѹÁ¦½Ç
Me.Text4 = 100 'Ãæ³ÝÂÖ³ÝÊý
Me.Text5 = 280 'Ãæ³ÝÂÖ×î´óÍâ°ë¾¶
Me.Text6 = 250 'Ãæ³ÝÂÖ×îСÄڰ뾶
End Sub
Private Sub Command2_Click()
On Error Resume Next
'³ÝÂÖCAD.ActiveDocument.Close
³ÝÂÖCAD.Documents.Add
Dim ns, n2, m, a, r, rb, ra, rf, csb, b, ha, hf, d, thi
Dim th(3)
Dim i
Dim r2max, r2min, fgheight
ns = Me.Text1 'µ¶¾ß³ÝÊý
m = Me.Text2 'Ä£Êý
a = Me.Text3 * pi / 180 'ѹÁ¦½Ç
n2 = Me.Text4 'Ãæ³ÝÂÖ³ÝÊý
r2max = Me.Text5 'Ãæ³ÝÂÖ×î´óÍâ°ë¾¶
r2min = Me.Text6 'Ãæ³ÝÂÖ×îСÄڰ뾶
fgheight = r2max / 4 'Ãæ³ÝÂֳݿí
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 '×ÅÉ«
r = m * ns / 2
rf = (r - 1.25 * m)
rb = r * Cos(a)
ra = r + m * 1.25
Dim height As Double
height = ra / 3 'µ¶¾ß³Ý¿í
Dim ³ÝÂÖ3D As Acad3DSolid
Dim cenpt(0 To 2) As Double
Dim topt(0 To 2) As Double
cenpt(0) = 0: cenpt(1) = 0: cenpt(2) = 0
topt(0) = 0: topt(1) = 0: topt(2) = -height / 2
'Set ³ÝÂÖ3D = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddCylinder(cenpt, ra, height)
'Dim Öá¿× As Acad3DSolid
'Set Öá¿× = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddCylinder(cenpt, ra / 3, height)
'³ÝÂÖ3D.Boolean acSubtraction, Öá¿×
'³ÝÂÖ3D.Color = acBlue
'ZoomAll
'Dim plineobj(0) As AcadLWPolyline
csb = Cos(a) * (pi * m / 2 + m * ns * (Tan(a) - (a)))
th(1) = (pi * m * Cos(a) - csb) / (2 * rb)
th(0) = th(1) / 3
th(2) = th(1) + Tan(a) - a
th(3) = th(1) + Tan(acos(rb / ra)) - acos(rb / ra)
thi = pi / ns
Dim curves(0 To 4) As AcadEntity
Dim points0(0 To 5) As Double
Dim points1(0 To 8) As Double
points0(0) = 0: points0(1) = rf 'µÚ0µã
points0(2) = rf * Sin(th(0)): points0(3) = rf * Cos(th(0)) 'µÚ1µã
points0(4) = rb * Sin(th(1)): points0(5) = rb * Cos(th(1)) 'µÚ2µã
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) = 0 'µÚ2µã
points1(3) = r * Sin(th(2)): points1(4) = r * Cos(th(2)): points1(5) = 0 'µÚ3µã
points1(6) = ra * Sin(th(3)): points1(7) = ra * Cos(th(3)): points1(8) = 0 'µÚ4µã
If rb < rf Then '»ùԲСÓÚ¸ùÔ²
points0(2) = points1(3) * 0.2: points0(3) = points0(1) + 0.25 * m * 0.03 'µÚ1µã
points0(4) = points1(3) * 0.7: points0(5) = points0(1) + 0.25 * m * 0.8 'µÚ2µã
points1(0) = points0(4) * 0.2: points1(1) = points0(5): points1(2) = 0 'µÚ2µã
End If
'ÓÉ0£¬1£¬2µã×é³É
Set curves(0) = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddLightWeightPolyline(points0)
curves(0).SetBulge 1, 0.2
Set curves(1) = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddSpline(points1, starttan, endtan) 'ÓÉ2,3,4µã×é³É
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(2) = curves(1).Mirror(point1, point2) 'µ¶¾ßÓұ߲¿·Ö
Set curves(3) = curves(0).Mirror(point1, point2)
Set curves(4) = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddArc(cenpt, ra, pi / 2 - th(3), pi / 2 + th(3)) 'Ô²»¡²¿·Ö
'curves.Color = acRed
'For i = 0 To 4
'Dim retval As Variant
'retval = curves(i).ArrayPolar(ns + 1, 2 * pi, cenpt)
'Next i
Dim cc As Variant
cc = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddRegion(curves)
Dim axispt(0 To 2) As Double
Dim axisdir(0 To 2) As Double
axispt(0) = 0: axispt(1) = 1: axispt(2) = 0
axisdir(0) = ra + fgheight / 2: axisdir(1) = 0: axisdir(2) = 0
Dim cc3d As Acad3DSolid
'Set cc3d = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddExtrudedSolid(cc(0), height, 0)
Set cc3d = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddRevolvedSolid(cc(0), axispt, axisdir, 2 * pi)
cc3d.Update
'Dim ³Ý²Û3D As Acad3DSolid
'Set ³Ý²Û3D = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddExtrudedSolid(³Ý²Û(0), height, 0)
'³Ý²Û3D.Update
'³Ý²Û3D.Move cenpt, topt
'Dim ³Ý²Û3DÕóÁÐ As Variant
'³Ý²Û3DÕóÁÐ = ³Ý²Û3D.ArrayPolar(ns + 1, 2 * pi, cenpt)
'For i = 0 To ns - 1
'³ÝÂÖ3D.Boolean acSubtraction, ³Ý²Û3DÕóÁÐ(i)
'Next i
'³Ý²Û3D.Delete
'³ÝÂÖCAD.ActiveDocument.ModelSpace.AddRegion(curves).Delete
'³Ý²Û.Delete
'³Ý²Û
'³ÝÂÖ3D.Boolean acSubtraction, ³Ý²Û3D
'³ÝÂÖ3D.Update
ZoomAll
'Dim toppt(0 To 2) As Double
'toppt(0) = 0: toppt(1) = 0: toppt(2) = fgheight / 3
'Dim Ãæ³ÝÂÖout As Acad3DSolid
'Dim Ãæ³ÝÂÖin As Acad3DSolid
'Set Ãæ³ÝÂÖout = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddCylinder(cenpt, r2max, fgheight)
'Set Ãæ³ÝÂÖin = ³ÝÂÖCAD.ActiveDocument.ModelSpace.AddCylinder(cenpt, r2min, fgheight / 3)
'Ãæ³ÝÂÖin.Move cenpt, toppt
'Ãæ³ÝÂÖout.Boolean acSubtraction, Ãæ³ÝÂÖin
'Dim axispt(0 To 2) As Double
'Dim axisdir(0 To 2) As Double
'axispt(0) = 0: axispt(1) = 1: axispt(2) = 0
'axisdir(0) = ra + fgheight / 2: axisdir(1) = 0: axisdir(2) = 0
'rotationagle = pi / 2
'Ãæ³ÝÂÖout.Rotate3D cenpt, axispt, -pi / 2
'Ãæ³ÝÂÖout.Move cenpt, axisdir
'Dim topt2(0 To 2) As Double
'topt2(0) = 0: topt2(1) = 0: topt2(2) = r2max - height / 2
'³ÝÂÖ3D.Move cenpt, topt2
End Sub
Private Sub Form_Load()
Me.Caption = "³ÝÂÖ¼Ó¹¤Èýά¶¯»­·ÂÕæ"
Me.Left = (Screen.Width - Me.Width)
Me.Top = 0
Me.Text1 = 27
Me.Text2 = 5
Me.Text3 = 20
Me.Text4 = 100
Me.Text5 = 280
Me.Text6 = 250
Dim ns, n2, m, a, r, rb, ra, rf, csb, umax, u, b, ha, hf
ha = 1.25 '³Ý¶¥¸ßϵÊý
hf = 1.25 '³Ý¸ú¸ßϵÊý
b = 20 '³Ý¿í
On Error Resume Next
Set ³ÝÂÖCAD = GetObject(, "autocad.application")
If Err Then
Err.Clear
Set ³ÝÂÖCAD = CreateObject("autocad.application")
If Err Then
MsgBox ("please install autocad")
Unload Me
Exit Sub
End If
End If
³ÝÂÖCAD.WindowState = acMax
End Sub |
|
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
发表于 2005-4-2 11:19:42
提升卡
置顶卡
沉默卡
变色卡
千斤顶
发表于 2005-4-2 18:53:23
