Jump to content

Extrude with taper angle in VBA


Joro--

Recommended Posts

Hi, can anybody help me with extruding along path with taper angle in VBA? Actually I am aware of the ExtrudeAlongPath method, but can I define a taper angle there? Any help will be appreciated...

Link to comment
Share on other sites

if you look at the AddExtrudedSolid topic in the Help file it gives you a complete example of creating an extruded solid ~ all you need to do is change the 0 degrees for whatever value you require

Link to comment
Share on other sites

Taper angle can surely be defined with the AddExtrudedSolid method. The problem is that I need extrusion along a path, which is a 2d polyline and gradual decrease of section of the extruded solid.

 

That's why I need an extrudedSolidAlongPath. Actually if I do this manually in ACad I can define a taper angle there, just don't see such as option in VBA....

Link to comment
Share on other sites

  • 3 years later...

Hi there,

 

Just wondering if anyone can help me. I have a square polygon and want to extrude it using two taper angles, one in the x direction, and one in the y direction. Is this possible?

Link to comment
Share on other sites

As mentioned previously, a lot of the command functionality available in the AutoCAD editor did not make it to the VBA (ActiveX) api. In this case, a square polygon extruded with multiple taper angles, the process isn’t directly available from the editor either.

 

 

The process could probably be done in either VBA or the editor by extruding with a taper equal to the steeper angle and “Slicing” the shallower ones. If you are still interested in pursuing this routine let me know, I have some functions that may help the cause.

Link to comment
Share on other sites

I switched tact off of my original suggestion of employing SLICE operations to one of - generate the appropriate line to act as a path, creates extrusion, Copy, Rotate, Intersect. See attached drawing for a visual of the process.

 

The routine is only a prototype so a full complement of error and situation checking is not yet in place. The other limitation is that the routine only processes LWPolylines on the World XY plane.

 

 

Option Explicit
Const PI As Double = 3.14159265358979


Sub UnEqualTaper()
'-------------------------------------------------------------------------------------

Dim Normal(0 To 2) As Double
Dim intCode(7) As Integer
Dim varData(7) As Variant
Dim lwPL As AcadLWPolyline
Dim intCount As Integer
With ThisDrawing
  .Utility.InitializeUserInput 4
  Normal(2) = 1#
     'create filter for closed LWPolys
     intCode(0) = 0: varData(0) = "LWPOLYLINE"
     intCode(1) = -4: varData(1) = "&="
     intCode(2) = 70: varData(2) = 1
     intCode(3) = -4: varData(3) = "&"
     intCode(4) = 70: varData(4) = 129
     intCode(5) = 90: varData(5) = 4
     intCode(6) = 67: varData(6) = 0
     intCode(7) = 210: varData(7) = Normal

  intCount = SoSSS(intCode, varData) - 1
  If intCount < 0 Then Exit Sub
Dim Sset As AcadSelectionSet
Dim i As Integer
Dim Ents(0) As AcadEntity
Dim entReg As AcadRegion
Dim dblOr(0 To 2) As Double
Dim dblHeight
Dim dblAngX As Double
Dim dblAngY As Double
Dim varRegs As Variant
Dim dblCentroid() As Double
  Set Sset = ThisDrawing.SelectionSets.Item("TempSSet")
  dblHeight = .Utility.GetDistance(, vbCr & "Height of extrusion:")
  dblAngX = .Utility.GetAngle(, vbCr & "Angle (in  degrees) for faces perpendicular to X axis: ")
  dblAngY = .Utility.GetAngle(, vbCr & "Angle (in  degrees) for faces perpendicular to Y axis: ")
Dim Ln As AcadLine
Dim lnTemp As AcadLine
Dim entSolid As Acad3DSolid
Dim entSolidTemp As Acad3DSolid
Set Ln = .ModelSpace.AddLine(dblOr, EndFromAngles(dblHeight, dblAngX, dblAngY))



For i = 0 To intCount
  Set Ents(0) = Sset.Item(i)
  varRegs = .ModelSpace.AddRegion(Ents)
  Set entReg = varRegs(0)
  dblCentroid = RegCentroidConversion(entReg.Centroid)
  Set lnTemp = Ln.Copy
  lnTemp.Move dblOr, dblCentroid
  Set entSolid = .ModelSpace.AddExtrudedSolidAlongPath(entReg, lnTemp)
  Set entSolidTemp = entSolid.Copy
  entSolidTemp.Rotate dblCentroid, PI
  entSolid.Boolean acIntersection, entSolidTemp
  lnTemp.Delete
  entReg.Delete
  Ents(0).Delete
Next

  Ln.Delete
End With
End Sub



Sub SSClear()
Dim SSS As AcadSelectionSets
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub

Function SoSSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSClear
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'pick selection set
  If IsMissing(grpCode) Then
     TempObjSS.SelectOnScreen
  Else
     TempObjSS.SelectOnScreen grpCode, dataVal
  End If
  SoSSS = TempObjSS.count
End Function


Function EndFromAngles(ByVal Height As Double, AngX As Double, AngY As Double) As Double()
Dim dblDummy(0 To 2) As Double
dblDummy(0) = -(Height * Tan(AngX))
dblDummy(1) = -(Height * Tan(AngY))
dblDummy(2) = Height
EndFromAngles = dblDummy
End Function

Function RegCentroidConversion(Point2d As Variant) As Double()
Dim dblDummy(0 To 2) As Double
dblDummy(0) = Point2d(0)
dblDummy(1) = Point2d(1)
dblDummy(2) = 0#
RegCentroidConversion = dblDummy
End Function

TaperedSolid.dwg

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...