topic Re: VBA revolve problem, help... in VBA Forum

VBA revolve problem, help...

suparhigh12345 — Tue, 29 Nov 2022 16:31:20 GMT

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.

Re: VBA revolve problem, help...

suparhigh12345 — Thu, 24 Nov 2022 21:27:16 GMT

DWG example (poly):

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

Re: VBA revolve problem, help...

Ed__Jobe — Wed, 30 Nov 2022 21:32:45 GMT

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

Re: VBA revolve problem, help...

suparhigh12345 — Thu, 01 Dec 2022 17:57:28 GMT

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

Re: VBA revolve problem, help...

Ed__Jobe — Thu, 01 Dec 2022 18:00:30 GMT

If you changed your code, show the revised code.

Re: VBA revolve problem, help...

suparhigh12345 — Thu, 01 Dec 2022 18:09:43 GMT

I'm probably doing it wrong

'' 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

Re: VBA revolve problem, help...

Ed__Jobe — Thu, 01 Dec 2022 18:15:54 GMT

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.

Re: VBA revolve problem, help...

suparhigh12345 — Fri, 02 Dec 2022 14:52:49 GMT

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

Re: VBA revolve problem, help...

Ed__Jobe — Thu, 01 Dec 2022 18:33:21 GMT

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.

Re: VBA revolve problem, help...

suparhigh12345 — Thu, 01 Dec 2022 18:57:54 GMT

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.

Re: VBA revolve problem, help...

Ed__Jobe — Mon, 12 Dec 2022 19:24:17 GMT

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

Re: VBA revolve problem, help...

suparhigh12345 — Thu, 15 Dec 2022 19:19:36 GMT

Hi, your code doesnt work.

Error: "compile error, sub function not defined"

Re: VBA revolve problem, help...

Ed__Jobe — Fri, 16 Dec 2022 00:27:52 GMT

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