Extrude Circle/Cylinder VBA

[Anonymous]

Im just starting to get my head around VBA in AutoCad. I have managed to write a code that creates a 2D truss in polylines by coordinates I have arranged in an Excel file. Now I need to extrude each member into a cylinder. Well Im not really that smart yet, having some hard time with choosing path and region. Any examples or advice would be much much much appreciated! Please! 

[Alfred.NESWADBA]

Hi,

1min to search the help and to get this sample 😉 .... or is there something else that you need help for?

Sub Example_AddExtrudedSolid()
    ' This example extrudes a solid from a region.
    ' The region is created from an arc and a line.
    
    Dim curves(0 To 1) As AcadEntity

    ' Define the arc
    Dim centerPoint(0 To 2) As Double
    Dim radius As Double
    Dim startAngle As Double
    Dim endAngle As Double
    centerPoint(0) = 5#: centerPoint(1) = 3#: centerPoint(2) = 0#
    radius = 2#
    startAngle = 0
    endAngle = 3.141592
    Set curves(0) = ThisDrawing.ModelSpace.AddArc(centerPoint, radius, startAngle, endAngle)
    
    ' Define the line
    Set curves(1) = ThisDrawing.ModelSpace.AddLine(curves(0).startPoint, curves(0).endPoint)
        
    ' Create the region
    Dim regionObj As Variant
    regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
    
    ' Define the extrusion
    Dim height As Double
    Dim taperAngle As Double
    height = 3
    taperAngle = 0
    
    ' Create the solid
    Dim solidObj As Acad3DSolid
    Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionObj(0), height, taperAngle)
    
    ' Change the viewing direction of the viewport
    Dim NewDirection(0 To 2) As Double
    NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
    ThisDrawing.ActiveViewport.direction = NewDirection
    ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
    ZoomAll
        
End Sub

Just one sample of extrusion, if you search through the VBA-help for "extrude" you'll find more.

And be careful, VBA is not the product I would start now developing with AutoCAD. On one side since AutoCAD 2010 there's the warning that it may not be continued in future releases and also working within a 64bit-environment pushes the performance down to .... (bad words are truncated by myself ;))

Good luck, - alfred -

[Anonymous]

Thank you so much for the fast reply! I've got this example already, didn't really ring the bell. Well I really don't have much background in programming full stop so it is not really going anywhere. Ive managed to get some sort of results, but a general design error pups up on the last line where Im trying to AddExtrudeSolidAlongPath method! It is probably something really silly, but I can't find the issue. Here is the code, if you have a second to look at it. Please don't laugh!  

Sub Truss_Polyline()

    Dim excelAPP As Object
    
    Set excelAPP = CreateObject("Excel.Application")
    
    excelAPP.Workbooks.Open ("d:\demo\Truss Finite Element Software V2.0_mine version.xlsm")

    Dim pline3DObj As AcadPolyline
    Dim stP As Long
    Dim enP As Long
    Dim i As Long
    Dim Point(0 To 5) As Double
    Dim XSection As Double
   
    
    Members = excelAPP.Worksheets("Main Page").Cells(6, 5)
    
    For i = 1 To Members
    
        stP = excelAPP.Worksheets("Elements").Cells(i + 1, 2)
        enP = excelAPP.Worksheets("Elements").Cells(i + 1, 3)
        XSection = excelAPP.Worksheets("Elements").Cells(i + 1, 5)
        
        
        ' Define the start and end points for the line
        Point(0) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 2):
        Point(1) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 3):
        Point(2) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 4)
        Point(3) = excelAPP.Worksheets("Nodes").Cells(enP + 1, 2):
        Point(4) = excelAPP.Worksheets("Nodes").Cells(enP + 1, 3):
        Point(5) = excelAPP.Worksheets("Nodes").Cells(enP + 1, 4)
    
    
       Set pline3DObj = ThisDrawing.ModelSpace.AddPolyline(Point())
    
    Dim objPath As AcadPolyline
    Dim varRegions As Variant
    Dim objEnts(0) As AcadEntity
    Dim radius As Double
    Dim objCircle As AcadCircle
    Dim objShape As Acad3DSolid
     
   radius = excelAPP.Worksheets("CHS").Cells(13 + XSection, 2) / 2
     
   Set objPath = pline3DObj
   
   Dim center(0 To 2) As Double
        center(0) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 2):
        center(1) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 3):
        center(2) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 4)

   Set objCircle = ThisDrawing.ModelSpace.AddCircle(center, radius)
   

   Set objEnts(0) = objCircle
   varRegions = ThisDrawing.ModelSpace.AddRegion(objEnts)
   
   Set objShape = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(varRegions(0), objPath)
   
   
    Next i
    
    Set excelAPP = Nothing


End Sub

 Thanks very much again! Miss Kalnina 

[Hallex]

Try this one instead

Think you have to use 3d polyline as path of extrusion:

{code}

Option Explicit

Sub Truss_Polyline()

Dim excelAPP As Object
Dim excelBook As Object
On Error GoTo Err_Control
Set excelAPP = CreateObject("Excel.Application")
Set excelBook = excelAPP.Workbooks.Open("c:\Test\Truss Finite Element Software V2.0_mine version.xlsm")
Dim pline3DObj As Acad3DPolyline '<--- use 3d Polyline as extrusion path
Dim stP As Long
Dim enP As Long
Dim i As Long
Dim Point(0 To 5) As Double
Dim XSection As Double
Dim Members As Long
Members = excelAPP.Worksheets("Main Page").Cells(6, 5)
Debug.Print "Members: " & Members
For i = 1 To Members
stP = excelAPP.Worksheets("Elements").Cells(i + 1, 2)
Debug.Print stP
enP = excelAPP.Worksheets("Elements").Cells(i + 1, 3)
Debug.Print enP
XSection = excelAPP.Worksheets("Elements").Cells(i + 1, 5)
' Define the start and end points for the line
Point(0) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 2)
Point(1) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 3)
Point(2) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 4)
Point(3) = excelAPP.Worksheets("Nodes").Cells(enP + 1, 2)
Point(4) = excelAPP.Worksheets("Nodes").Cells(enP + 1, 3)
Point(5) = excelAPP.Worksheets("Nodes").Cells(enP + 1, 4)

Set pline3DObj = ThisDrawing.ModelSpace.Add3DPoly(Point)
Dim objPath As Acad3DPolyline
Dim varRegions As Variant
Dim objEnts(0) As AcadEntity
Dim radius As Double
Dim objCircle As AcadCircle
Dim objShape As Acad3DSolid
radius = excelAPP.Worksheets("CHS").Cells(13 + XSection, 2) / 2
Set objPath = pline3DObj
Dim center(0 To 2) As Double
center(0) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 2)
center(1) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 3)
center(2) = excelAPP.Worksheets("Nodes").Cells(stP + 1, 4)
Set objCircle = ThisDrawing.ModelSpace.AddCircle(center, radius)
ZoomAll
Set objEnts(0) = objCircle
varRegions = ThisDrawing.ModelSpace.AddRegion(objEnts)
Set objShape = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(varRegions(0), objPath)

Next i

excelBook.Close
excelAPP.Quit
Set excelBook = Nothing
Set excelAPP = Nothing

Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If

End Sub

{code}

~'J'~

[Anonymous]

Thanks very much again, but still doesn't work. When debuging the code, it stops at set entity showing that the region is empty thus it stops there and jumps to error check. I can't understand why, cause I've done it exactly the same way as in examples. Anyway, the error pups up eventually says that the call was rejected bycallee. The programm still draws one of the members of truss and a circle at the start point, it's just that they are laying in the same plane, which is probably not very promissing. Why is this so complicated? 

[Hallex]

My guess is this happens by reason of that the every region

should be created in the drawing XY plane in other words

it have the normal vector same as Z axis then you could be able

to extrude them all , so you need to create all parts in this plane, then apply

move and rotate 3d operations then do union all of the parts right

Can you upload your .xlsm (2007) file and drawing example (A2007) how it will be looks like,

maybe I can do it?

~'J'~

[Anonymous]

Thanks Hallex, i have kinda given up on it, Im trying something else now. If you still wanna have a look at it, that would be awesome.  Is .xlsm (2010) alright? Can you please post your personal email?

[Hallex · Accepted solution]

Sorry no

But you can send your files with www.yousendit.com or so

again I have MS Office 2007 only I'm afraid I can't open Excel 2010

saveas it in this release

and also you may want to look at this thread for more:

http://www.theswamp.org/index.php?topic=13604.0

Here is just a dummy example how to do the work easy

without transformation matrix

{code}

Option Explicit

Sub test()
Dim pl3d1 As Acad3DPolyline
Dim pl3d2 As Acad3DPolyline
    Dim pts(0 To 8) As Double
   
    ' Create the array of pts
    pts(0) = 0: pts(1) = 0: pts(2) = 0
    pts(3) = 0: pts(4) = 0: pts(5) = 10
    pts(6) = 1#: pts(7) = 0.5: pts(8) = 12.4
   
    ' Create first 3DPolyline in model space
    Set pl3d1 = ThisDrawing.ModelSpace.Add3DPoly(pts)
Dim varRegions As Variant
Dim objEnts(0) As AcadEntity
Dim radius As Double
Dim objCircle As AcadCircle
Dim objShape1 As Acad3DSolid
Dim objShape2 As Acad3DSolid
radius = 0.5

Dim cpt(0 To 2) As Double
cpt(0) = 0#
cpt(1) = 0#
cpt(2) = 0#
Set objCircle = ThisDrawing.ModelSpace.AddCircle(cpt, radius)

Set objEnts(0) = objCircle
varRegions = ThisDrawing.ModelSpace.AddRegion(objEnts)
Set objShape1 = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(varRegions(0), pl3d1)

' change last point to create a second 3DPolyline, first 2 points is the same
pts(6) = -1#: pts(7) = -0.5: pts(8) = 12.4
' Create second 3DPolyline in model space
Set pl3d2 = ThisDrawing.ModelSpace.Add3DPoly(pts)
Set objShape2 = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(varRegions(0), pl3d2)
' perform union operation to solids
objShape1.Boolean acUnion, objShape2
' define axis line points
Dim axpt1(2) As Double
axpt1(0) = 0#: axpt1(1) = 0#: axpt1(2) = 0#
Dim axpt2(2) As Double
axpt2(0) = 0#: axpt2(1) = 1#: axpt2(2) = 0#
' rotate solid around this axis
objShape1.Rotate3D axpt2, axpt1, 1.5708 '~90 degs
'clean up
objCircle.Delete
varRegions(0).Delete
pl3d1.Delete
pl3d2.Delete
ZoomExtents
End Sub

{code}

[Anonymous]

Thanks very much, it did help although I changed the method Im using. I don’t have time to sort out the extrusion method but I will give it a try later on.

Many thanks  

[Hallex]

Hope you could be able to do it yourself

Happy computing and Cheers 🙂

~'J'~