Hi Leonardo
Here is something similar on what you want
Give this a try
Dim objArr(0) As AcadEntity
Dim opath As Acad3DPolyline
Dim ocirc As AcadCircle
Dim oSol As Acad3DSolid
Dim RegVar As Variant
Dim oReg As AcadRegion
Dim rad As Double
Dim dia As Double
Dim pth As Double
Dim hgt As Double
Dim ang As Double
Dim pi As Double
Dim da As Double
Dim dz As Double
Dim dh As Double
Dim dr As Double
Dim num, iCnt, i, j As Integer
Dim cent(0 To 2) As Double
Dim varPt As Variant
Dim norm(0 To 2) As Variant
Dim stp(0 To 2) As Double
Dim strpt As String
Dim ptArr() As Double
Dim orig As Variant
Dim xax(0 To 2) As Double
Dim yax(0 To 2) As Double
Dim ucsName As String
Dim leng As Double
Dim curUCS As AcadUCS
Dim ucsMatx As Variant
Sub Helix()
rad = 100# ' outer radius of helix
dia = 25# ' wire diameter
pth = 25# 'pitch
num = 4 'number of rotation
hgt = pth * num
pi = Atn(1) * 4
dz = pth / 128 'number of division per rotation
dh = dz
da = pi / 64
dr = da
cent(0) = 0#: cent(1) = 0#: cent(2) = 0#:
iCnt = 0
On Error GoTo sayme
Do While dz <= hgt
varPt = ThisDrawing.Utility.PolarPoint(cent, da, rad)
ReDim Preserve ptArr(iCnt + 2)
ptArr(iCnt) = varPt(0)
ptArr(iCnt + 1) = varPt(1)
ptArr(iCnt + 2) = dz
dz = dz + dh
da = da + dr
iCnt = iCnt + 3
Loop
leng = Sqr((ptArr(3) ^ 2) + (ptArr(4) ^ 2) + (ptArr(5) ^ 2))
norm(0) = ptArr(3)
norm(1) = ptArr(4)
norm(2) = ptArr(5)
ThisDrawing.SendCommand "_SHADEMODE" & vbCr & "_2" & vbCr
Set opath = ThisDrawing.ModelSpace.Add3DPoly(ptArr)
strpt = Replace(CStr(norm(0)), ",", ".") & "," & _
Replace(CStr(norm(1)), ",", ".") & "," & _
Replace(CStr(norm(2)), ",", ".")
ThisDrawing.SendCommand "_-VIEW" & vbCr & "_RIGHT" & vbCr
ThisDrawing.SendCommand "_UCS" & vbCr & "_N" & vbCr & "_ZA" & vbCr & "0.0,0.0,0.0" & vbCr & strpt & vbCr & vbCr
stp(0) = ptArr(0): stp(1) = ptArr(1): stp(2) = ptArr(2)
Set ocirc = ThisDrawing.ModelSpace.AddCircle(stp, dia / 2)
Set objArr(0) = ocirc
RegVar = ThisDrawing.ModelSpace.AddRegion(objArr)
Set oReg = RegVar(0)
Set oSol = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(oReg, opath)
ThisDrawing.SendCommand "_UCS" & vbCr & "_World" & vbCr
ThisDrawing.SendCommand "_SHADEMODE" & vbCr & "_G" & vbCr
sayme:
MsgBox Err.Description
End Sub
Fatty
~'J'~
