VBA revolve problem, help...

suparhigh12345 · ‎11-24-2022

Hi, I have one problem, with this code below, there is no way to revolve polyline around red centerline if polyline is set at specific angle. Example (Drawing1test.dwg):

Error: "General modeling failure"

Public Sub TestAddRevolvedSolid()
Dim objShape As AcadLWPolyline
Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varPnt1 As Variant
Dim dblOrigin(2) As Double
Dim varVec As Variant
Dim dblAngle As Double
Dim objEnts() As AcadEntity
Dim varRegions As Variant
Dim varItem As Variant

'' draw the shape and get rotation from user
With ThisDrawing.Utility
'' pick a shape
On Error Resume Next
.GetEntity objShape, varPick, "pick a polyline shape"
If Err Then
MsgBox "You did not pick the correct type of shape"
Exit Sub
End If
On Error GoTo Done
objShape.Closed = True
'' add pline to region input array
ReDim objEnts(0)
Set objEnts(0) = objShape
'' get the axis points
.InitializeUserInput 1
varPnt1 = .GetPoint(, vbLf & "Pick an origin of revolution: ")
.InitializeUserInput 1
varVec = .GetPoint(dblOrigin, vbLf & _
"Indicate the axis of revolution: ")
'' get the angle to revolve
.InitializeUserInput 1
dblAngle = .GetAngle(, vbLf & "Angle to revolve: ")
End With
'' make the region, then revolve it into a solid
With ThisDrawing.ModelSpace
'' make region from closed pline
varRegions = .AddRegion(objEnts)
'' revolve solid about axis
Set objEnt = .AddRevolvedSolid(varRegions(0), varPnt1, varVec, _
dblAngle)
objEnt.color = acRed
End With
Done:
If Err Then MsgBox Err.Description
'' delete the temporary geometry
For Each varItem In objEnts: varItem.Delete: Next
If Not IsEmpty(varRegions) Then

For Each varItem In varRegions: varItem.Delete: Next
End If
ThisDrawing.SendCommand "_shade" & vbCr
End Sub

any Help? Thank you

Moderator edit: put code into code window using </> button.

suparhigh12345 · ‎11-24-2022

DWG example (poly):

P.s It doesnt even matter if poly is a 3d poly line or AcadLWPolyline. There is still error... any help?

Ed__Jobe · ‎11-30-2022

You are setting varVec to a point. While the vector is a 3 element array of doubles, it is not the endpoint of the axis. You could select the start point and end point of your axis and then use the following function.

varVec = VectorFrom2pt(startpoint, endpoint)

Public Function VectorFrom2pt(pt1 As Variant, pt2 As Variant) As Variant
    Dim vec(0 To 2) As Double
    vec(0) = pt1(0) - pt2(0)
    vec(1) = pt1(1) - pt2(1)
    vec(2) = pt1(2) - pt2(2)
    VectorFrom2pt = vec
End Function

Ed

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

suparhigh12345 · ‎12-01-2022

Thank you. Can u make a full code sample cuz I am still getting the same error.

Ed__Jobe · ‎12-01-2022

If you changed your code, show the revised code.

Ed

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

suparhigh12345 · ‎12-01-2022

I'm probably doing it wrong

Public Sub TestAddRevolvedSolid()
Dim objShape As AcadLWPolyline
Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varPnt1 As Variant
Dim dblOrigin(2) As Double
Dim dblAngle As Double
Dim objEnts() As AcadEntity
Dim varRegions As Variant
Dim varItem As Variant

'' draw the shape and get rotation from user
With ThisDrawing.Utility
'' pick a shape
On Error Resume Next
.GetEntity objShape, varPick, "pick a polyline shape"
If Err Then
MsgBox "You did not pick the correct type of shape"
Exit Sub
End If
On Error GoTo Done
objShape.Closed = True
'' add pline to region input array
ReDim objEnts(0)
Set objEnts(0) = objShape
'' get the axis points
.InitializeUserInput 1
varPnt1 = .GetPoint(, vbLf & "Pick an origin of revolution: ")
.InitializeUserInput 1
varVec = VectorFrom2pt(StartPoint, EndPoint)
'' get the angle to revolve
.InitializeUserInput 1
dblAngle = .GetAngle(, vbLf & "Angle to revolve: ")
End With
'' make the region, then revolve it into a solid
With ThisDrawing.ModelSpace
'' make region from closed pline
varRegions = .AddRegion(objEnts)
'' revolve solid about axis
Set objEnt = .AddRevolvedSolid(varRegions(0), varPnt1, varVec, _
dblAngle)
objEnt.color = acRed
End With
Done:
If Err Then MsgBox Err.Description
'' delete the temporary geometry
For Each varItem In objEnts: varItem.Delete: Next
If Not IsEmpty(varRegions) Then

For Each varItem In varRegions: varItem.Delete: Next
End If
ThisDrawing.SendCommand "_shade" & vbCr
End Sub

Public Function VectorFrom2pt(pt1 As Variant, pt2 As Variant) As Variant
Dim vec(0 To 2) As Double
vec(0) = pt1(0) - pt2(0)
vec(1) = pt1(1) - pt2(1)
vec(2) = pt1(2) - pt2(2)
VectorFrom2pt = vec
End Function

Ed__Jobe · ‎12-01-2022

It's hard to read when you don't put your code in a code window. Not only do you lose the color formatting, but all the indents are not preserved. Can you edit your post and choose Visual Basic as the code format?

Also, you typed "varVec = VectorFrom2pt(StartPoint, EndPoint)". You don't have StartPoint and EndPoint in your sub. Those are just variable I used so you could get the idea.

Ed

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

suparhigh12345 · ‎12-01-2022

Public Sub TestAddRevolvedSolid()
Dim objShape As AcadLWPolyline
Dim varPick As Variant
Dim objEnt As AcadEntity
Dim varPnt1 As Variant
Dim dblOrigin(2) As Double
Dim dblAngle As Double
Dim objEnts() As AcadEntity
Dim varRegions As Variant
Dim varItem As Variant
Dim StartPoint As Variant
Dim EndPoint As Variant

'' draw the shape and get rotation from user
With ThisDrawing.Utility
'' pick a shape
On Error Resume Next
.GetEntity objShape, varPick, "pick a polyline shape"
If Err Then
MsgBox "You did not pick the correct type of shape"
Exit Sub
End If
On Error GoTo Done
objShape.Closed = True
'' add pline to region input array
ReDim objEnts(0)
Set objEnts(0) = objShape
'' get the axis points
.InitializeUserInput 1
varPnt1 = .GetPoint(, vbLf & "Pick an origin of revolution: ")
.InitializeUserInput 1
StartPoint = ThisDrawing.Utility.GetPoint(, "")
EndPoint = ThisDrawing.Utility.GetPoint(, "")
varVec = VectorFrom2pt(StartPoint, EndPoint)
'' get the angle to revolve
.InitializeUserInput 1
dblAngle = .GetAngle(, vbLf & "Angle to revolve: ")
End With
'' make the region, then revolve it into a solid
With ThisDrawing.ModelSpace
'' make region from closed pline
varRegions = .AddRegion(objEnts)
'' revolve solid about axis
Set objEnt = .AddRevolvedSolid(varRegions(0), varPnt1, varVec, _
dblAngle)
objEnt.color = acRed
End With
Done:
If Err Then MsgBox Err.Description
'' delete the temporary geometry
For Each varItem In objEnts: varItem.Delete: Next
If Not IsEmpty(varRegions) Then

For Each varItem In varRegions: varItem.Delete: Next
End If
ThisDrawing.SendCommand "_shade" & vbCr
End Sub

Public Function VectorFrom2pt(pt1 As Variant, pt2 As Variant) As Variant
Dim vec(0 To 2) As Double
vec(0) = pt1(0) - pt2(0)
vec(1) = pt1(1) - pt2(1)
vec(2) = pt1(2) - pt2(2)
VectorFrom2pt = vec
End Function

Ed__Jobe · ‎12-01-2022

I'm not sure how you are picking the points. You prompt for an axis origin, then a StartPoint and EndPoint. You don't need to prompt for an origin if you prompt for a start point. The rotation origin is the start point of the axis and the vector is returned by the function I gave you. sorry I don't have more time right now to actually test this myself.

Ed

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

suparhigh12345 · ‎12-01-2022

1.pick: midpoint of red centerline

2.pick: leftpoint of red centerline

3.pick: rightpoint of red centerline

can u check 44. line?

varPnt1 is asked for?....

I dont know what the problem is but there is still an error.

Ed__Jobe · ‎12-12-2022

The drawing you posted has the polyline created with 5 line segments. When you create a rectangle polyline, you should only use 3 line segments and then use the Close option for the 4th segment.

Also, your code doesn't account for the region and axis to not be coplanar withe the current ucs. I started from scratch to create some modular and readable code. There's not a lot of error checking like the REVOLVE command does, but it works when the entities are in the world ucs. For other ucs's you will have to add code to do coordinate transformations. I would probably use the region to create a temporary ucs and transform the axis coords to that ucs.


Public Sub RotPoly3D()
    
    On Error GoTo Err_Control
    Dim ss As AcadSelectionSet
    ThisDrawing.Utility.Prompt "\nSelect a coplanar Polyline:> "
    Set ss = GetSS_ByObjFilter("line,arc")
    Dim ary() As AcadEntity
    SStoArray ss, ary
    Dim vRegions As Variant
    vRegions = ThisDrawing.ModelSpace.AddRegion(ary)
    
    Dim pt1 As Variant
    Dim pt2 As Variant
    Dim vVector As Variant
    ThisDrawing.Utility.InitializeUserInput 1
    pt1 = ThisDrawing.Utility.GetPoint(, "\nSelect start point of rotation axis:>")
    pt2 = ThisDrawing.Utility.GetPoint(pt1, "\nSelect end point of rotation axis:>")
    vVector = VectorFrom2pt(pt1, pt2)
    
    Dim oEnt As Acad3DSolid
    Set oEnt = ThisDrawing.ModelSpace.AddRevolvedSolid(vRegions(0), pt1, vVector, 2 * PI)
'    oent.Material =
    
    
Exit_Here:
    Exit Sub
Err_Control:
    Select Case Err.Number
    'Add your Case selections here
    Case Is = -2147352567
        ' Nothing was selected.
        Err.Clear
        Resume Exit_Here
    Case Else
        MsgBox Err.Number & ", " & Err.Description, , "RotPoly3D"
        Err.Clear
        Resume Exit_Here
    End Select
End Sub


Public Function VectorFrom2pt(pt1 As Variant, pt2 As Variant) As Variant
    Dim vec(0 To 2) As Double
    vec(0) = pt1(0) - pt2(0)
    vec(1) = pt1(1) - pt2(1)
    vec(2) = pt1(2) - pt2(2)
    VectorFrom2pt = vec
End Function

Public Function SStoArray(ss As AcadSelectionSet, ary() As AcadEntity)

    Dim cnt As Integer
    cnt = ss.Count() - 1
'    Dim ary() As AcadEntity
    Dim i As Integer
    ReDim ary(0)
    For i = 0 To cnt
        Set ary(i) = ss(i)
        If i < cnt Then ReDim Preserve ary(UBound(ary) + 1)
    Next
    SStoArray = ary
    
End Function

Public Function GetSS_ByObjFilter(filter As String) As AcadSelectionSet
    'creates an filtered ss
    Dim s2 As AcadSelectionSet      'for filtered ss
    
    Dim intFtyp(0) As Integer                       ' setup for the filter
    Dim varFval(0) As Variant
    Dim varFilter1, varFilter2 As Variant
    intFtyp(0) = 0: varFval(0) = filter           ' get only filtered entities
    varFilter1 = intFtyp: varFilter2 = varFval
    Set s2 = AddSelectionSet("ssFiltered")              ' create or get the set
    s2.Clear                                        ' clear the set
    s2.SelectOnScreen varFilter1, varFilter2        ' do it

    s2.Highlight True
    s2.Update
    Set GetSS_ByObjFilter = s2

End Function

Ed

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

suparhigh12345 · ‎12-15-2022

Hi, your code doesnt work.

Error: "compile error, sub function not defined"

?

Ed__Jobe · ‎12-15-2022

Looks like I forgot about the AddSelectionSet function. I’ve posted it recently. Search this forum for it.

Ed

Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

Community

VBA revolve problem, help...

VBA revolve problem, help...

VBA revolve problem, help...

Ed

Ed

Ed

Ed

Ed

Ed