在VBA中，怎么用Spile画螺旋线？

eeko

在VBA中，怎么用Spile画螺旋线？谁会知道，请赐教！

topirol

看看下面



http://www.mjtd.com/function/list.asp?id=76&ordertype=byletter

mccad

其实也就是通过公式计算点，然后再形成一条样条曲线罢了

eeko

我是用公式生成点，然后手工用Spline连成圆锥螺旋线，可是用在vba中，用spline时，生成的只是一团"乱麻",不知是什么原因?而且object.AddSpline(PointsArray, StartTangent, EndTangent)中的“StartTangent, EndTangent"不知要怎么制定。请高手帮帮我。

mccad

2. Sub addsph()
   
3.     Dim EentPnt As Variant
   
4.     EentPnt = ThisDrawing.Utility.GetPoint(, "GetPoint")
   
5.    
   
6. AddHelix EentPnt, 5, 45, 10, 5
   
7. End Sub
   
8. Public Function AddHelix(varCentPnt As Variant, _
   
9. dblRadius As Double, dblStartAng As Double, _
   
10. dblPitch As Double, dblRot As Double) As AcadSpline
    
11.   Dim objPoly As AcadSpline
    
12.   Dim objSpace As AcadBlock
    
13.   Dim objUtil As AcadUtility
    
14.   Dim varSegments As Variant
    
15.   Dim dblSegInclAng As Double
    
16.   Dim dblSegPitch As Double
    
17.   Dim dblSegAng As Double
    
18.   Dim varPitchPnt As Variant
    
19.   Dim intCnt As Integer
    
20.   Dim dblPnts() As Double
    
21.   Dim intLoopCnt As Integer
    
22.   Dim intVertCnt As Integer
    
23.   Dim intCoordCnt As Integer
    
24.   On Error GoTo Err_Control
    
25.   If ThisDrawing.ActiveSpace = acModelSpace Then
    
26.     Set objSpace = ThisDrawing.ModelSpace
    
27.   Else
    
28.     Set objSpace = ThisDrawing.PaperSpace
    
29.   End If
    
30.   Set objUtil = ThisDrawing.Utility
    
31.   varSegments = ThisDrawing.GetVariable("SURFTAB1")
    
32.   dblSegInclAng = (2 * (Atn(1) * 4)) / varSegments
    
33.   dblSegPitch = dblPitch / varSegments
    
34.   dblSegAng = dblStartAng - dblSegInclAng
    
35.   intLoopCnt = CInt(1 + (varSegments * dblRot))
    
36.   ReDim dblPnts((intLoopCnt * 3) - 1)
    
37.   For intCnt = 1 To intLoopCnt
    
38.     dblSegAng = dblSegInclAng + dblSegAng
    
39.     varPitchPnt = objUtil.PolarPoint(varCentPnt, _
    
40.     dblSegAng, dblRadius)
    
41.     varCentPnt(2) = varCentPnt(2) + dblSegPitch
    
42.     For intVertCnt = 0 To 2
    
43.       dblPnts(intCoordCnt) = varPitchPnt(intVertCnt)
    
44.       intCoordCnt = intCoordCnt + 1
    
45.     Next
    
46.   Next intCnt
    
47.   Dim st(2) As Double
    
48.   Dim et(2) As Double
    
49.   st(0) = 0: st(1) = 0: st(2) = 0
    
50.   et(0) = 0: et(1) = 0: et(2) = 0
    
51.   Set objPoly = objSpace.AddSpline(dblPnts, st, et)
    
52.   Set AddHelix = objPoly
    
53. Exit_Here:
    
54.   Exit Function
    
55. Err_Control:
    
56.   Select Case Err.Number
    
57.   'Cases here
    
58.   Case Else
    
59.     MsgBox Err.Description
    
60.     Err.Clear
    
61.     Resume Exit_Here
    
62.   End Select
    
63. End Function

Sub addsph()<br />     Dim EentPnt As Variant<br />     EentPnt = ThisDrawing.Utility.GetPoint(, "GetPoint")<br />     <br /> AddHelix EentPnt, 5, 45, 10, 5<br /> End Sub<br /> Public Function AddHelix(varCentPnt As Variant, _<br /> dblRadius As Double, dblStartAng As Double, _<br /> dblPitch As Double, dblRot As Double) As AcadSpline<br />   Dim objPoly As AcadSpline<br />   Dim objSpace As AcadBlock<br />   Dim objUtil As AcadUtility<br />   Dim varSegments As Variant<br />   Dim dblSegInclAng As Double<br />   Dim dblSegPitch As Double<br />   Dim dblSegAng As Double<br />   Dim varPitchPnt As Variant<br />   Dim intCnt As Integer<br />   Dim dblPnts() As Double<br />   Dim intLoopCnt As Integer<br />   Dim intVertCnt As Integer<br />   Dim intCoordCnt As Integer<br />   On Error GoTo Err_Control<br />   If ThisDrawing.ActiveSpace = acModelSpace Then<br />     Set objSpace = ThisDrawing.ModelSpace<br />   Else<br />     Set objSpace = ThisDrawing.PaperSpace<br />   End If<br />   Set objUtil = ThisDrawing.Utility<br />   varSegments = ThisDrawing.GetVariable("SURFTAB1")<br />   dblSegInclAng = (2 * (Atn(1) * 4)) / varSegments<br />   dblSegPitch = dblPitch / varSegments<br />   dblSegAng = dblStartAng - dblSegInclAng<br />   intLoopCnt = CInt(1 + (varSegments * dblRot))<br />   ReDim dblPnts((intLoopCnt * 3) - 1)<br />   For intCnt = 1 To intLoopCnt<br />     dblSegAng = dblSegInclAng + dblSegAng<br />     varPitchPnt = objUtil.PolarPoint(varCentPnt, _<br />     dblSegAng, dblRadius)<br />     varCentPnt(2) = varCentPnt(2) + dblSegPitch<br />     For intVertCnt = 0 To 2<br />       dblPnts(intCoordCnt) = varPitchPnt(intVertCnt)<br />       intCoordCnt = intCoordCnt + 1<br />     Next<br />   Next intCnt<br />   Dim st(2) As Double<br />   Dim et(2) As Double<br />   st(0) = 0: st(1) = 0: st(2) = 0<br />   et(0) = 0: et(1) = 0: et(2) = 0<br />   Set objPoly = objSpace.AddSpline(dblPnts, st, et)<br />   Set AddHelix = objPoly<br /> Exit_Here:<br />   Exit Function<br /> Err_Control:<br />   Select Case Err.Number<br />   'Cases here<br />   Case Else<br />     MsgBox Err.Description<br />     Err.Clear<br />     Resume Exit_Here<br />   End Select<br /> End Function

huiyi88

cad2007开始就有helix命令，怎么利用vba来调用这个命令来画图，实现参数化呢？谢谢回复。