为什么我画的凸轮拉伸不起来
我用函数和polyline命令画了外形 轮廓，闭合了然后使用addregion命令添加面域。然后addextrudedsolid 命令拉伸实体
可是运行后，提示addregion失败。
请问高手怎么回事。除了这样拉伸，还有那种方法拉伸。我画的事凸轮机构
~以下是我的代码
Sub tulun()
Dim tulunobj As Acad3DSolid
Dim curves(0 To 3) As AcadEntity
Dim points(0 To 5) As Double
Dim points1(0 To 5) As Double
Dim x1 As Double
Dim x2 As Double
Dim y1 As Double
Dim y2 As Double
Dim n1 As Double
Dim n2 As Double
Dim m1 As Double
Dim m2 As Double
Dim centpoint(0 To 2) As Double
Dim radius As Double
Dim sangle As Double
Dim eangle As Double
Dim sangle1 As Double
'定义参数
x1 = 0
y1 = 0
n1 = 0
m1 = 0
centpoint(0) = 4
centpoint(1) = 0
centpoint(2) = 0
radius = 8
sangle = 3 * 3.1415926 / 2
eangle = 3.1415926 / 2
sangle1 = 0
Do While x1 < 4
x2 = x1 + 0.01
y2 = Sqr(16 * x2)
points(0) = x1: points(1) = y1: points(2) = 0
points(3) = x2: points(4) = y2: points(5) = 0
Set curves(0) = ThisDrawing.ModelSpace.AddPolyline(points)
x1 = x2
y1 = y2
Loop
Do While n1 < 4
n2 = n1 + 0.1
m2 = Sqr(16 * n2) * (-1)
points1(0) = n1: points1(1) = m1: points1(2) = 0
points1(3) = n2: points1(4) = m2: points1(5) = 0
Set curves(1) = ThisDrawing.ModelSpace.AddPolyline(points1)
n1 = n2
m1 = m2
Loop
Set curves(2) = ThisDrawing.ModelSpace.AddArc(centpoint, radius, sangle, sangle1)
Set curves(3) = ThisDrawing.ModelSpace.AddArc(centpoint, radius, sangle1, eangle)
Dim regionobj As AcadRegion
regionobj = ThisDrawing.ModelSpace.AddRegion(curves)
On Error Resume Next
Dim height As Double
Dim langle As Double
height = 10
langle = 0
Set tulunobj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobj(0), height, langle)
End Sub
页:
[1]