这是我去年刚学VBA是写的一个三维螺旋线程序

cag

ningyong58

好好学习这段程序,在工作中比较有用.

还有MJTD的VBA函数

函数名：AddHelix

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

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