Orientated Minimum Rangebox for Solid Body Faceshell

william · ‎09-21-2021

Hello
I have a multi body part with a single solid representing multiple timber rails.

What I would like to be able to do is analyse the solid body that represents the rails, and calculate the length/width/thickness for each rail.
The SurfaceBody.OrientedMinimumRangeBox Property works fine for the whole solid, but I would need to do the same to the faceshells belonging to the solid body.
The code that I have so far works with the x,y,z co-ordinates of the faceshell, but I would like to know how to get the correct dimensions for a faceshell that is not aligned to the x,y,z axis.
Part File attached, with rules inside.

Any ideas?

Threads that I have referenced for the code are:

https://forums.autodesk.com/t5/inventor-ilogic-api-vba-forum/faceshell-orientedrangebox/m-p/10472442

https://forums.autodesk.com/t5/inventor-ilogic-api-vba-forum/getting-accurate-rangebox-xyz-values/m-...

Code Snippet 1 (Faceshell Rangebox)

doc = ThisDoc.Document 
oDef = doc.ComponentDefinition
Dim oSB As SurfaceBody
For Each oSB In oDef.SurfaceBodies
	If oSB.Name.Contains("REF_RAILS") Then
			For Each fs As FaceShell In oSB.FaceShells
				If fs.IsVoid Then Continue For
				Dim DeltaX, DeltaY, DeltaZ As Double
				Dim fsBox As Box = fs.RangeBox
				DeltaX = fsBox.MaxPoint.X - fsBox.MinPoint.X
				DeltaY = fsBox.MaxPoint.Y - fsBox.MinPoint.Y
				DeltaZ = fsBox.MaxPoint.Z - fsBox.MinPoint.Z
				' Convert lengths to document's length units.
				Dim uom As UnitsOfMeasure = doc.UnitsOfMeasure

				DeltaX = uom.ConvertUnits(DeltaX, "cm", uom.LengthUnits)
				DeltaY = uom.ConvertUnits(DeltaY, "cm", uom.LengthUnits)
				DeltaZ = uom.ConvertUnits(DeltaZ, "cm", uom.LengthUnits)

				' Sort lengths from smallest to largest.
				Dim lengths As New List(Of Double) From {DeltaX, DeltaY, DeltaZ }
				lengths.Sort

				Dim minLength As Double = lengths(2)
				Dim midLength As Double = lengths(1)
				Dim maxLength As Double = lengths(0)

				' Display minimum rangebox size.
				MessageBox.Show("Rangebox Size: " &
					minLength.ToString("#.###") & " x " & midLength.ToString("#.###") & " x " & maxLength.ToString("#.###"),
					oSB.Name, MessageBoxButtons.OK, MessageBoxIcon.Information)
			Next
		End If
Next

Code Snippet 2 (Surface Body Orientated Minimum Rangebox)

doc = ThisDoc.Document 
oDef = doc.ComponentDefinition

' Get surface body to measure
Dim oSB As SurfaceBody
For Each oSB In oDef.SurfaceBodies
	Dim minBox As OrientedBox = oSB.OrientedMinimumRangeBox

	' Get length of each side of mininum range box.
	Dim dir1 As Double = minBox.DirectionOne.Length
	Dim dir2 As Double = minBox.DirectionTwo.Length
	Dim dir3 As Double = minBox.DirectionThree.Length

	' Convert lengths to document's length units.
	Dim uom As UnitsOfMeasure = doc.UnitsOfMeasure

	dir1 = uom.ConvertUnits(dir1, "cm", uom.LengthUnits)
	dir2 = uom.ConvertUnits(dir2, "cm", uom.LengthUnits)
	dir3 = uom.ConvertUnits(dir3, "cm", uom.LengthUnits)

	' Sort lengths from smallest to largest.
	Dim lengths As New List(Of Double) From {dir1, dir2, dir3 }
	lengths.Sort

	Dim minLength As Double = lengths(0)
	Dim midLength As Double = lengths(1)
	Dim maxLength As Double = lengths(2)

	' Display minimum rangebox size.
	MessageBox.Show(" Oriented Minimum Rangebox Size: " &
		minLength.ToString("#.###") & " x " & midLength.ToString("#.###") & " x " & maxLength.ToString("#.###"),
		oSB.Name, MessageBoxButtons.OK, MessageBoxIcon.Information)
Next

william · ‎09-22-2021

@BrianEkins
You would know if this if it is possible or not. Any suggestions?

josiah.fordCEEGJ · ‎10-06-2021

@william I have an iLogic Rule that is halfway there and creates Transient BReps that represent a single faceshell, and uses OrientedMinimumRangeBox to measure that before spitting out the sizes into the solid body name. Below is some of the code that I have done (with some company specific bits stripped out, so it wouldnt run as is). If you ran a For Next Loop that went through all the faceshells in the solid and wrote the data out somewhere that could potentially work for what you need. The oTransSolids.FaceShells sometimes like to error which is why there's a try catch around it. Hopefully this gives a direction somewhat.

Dim oPartDoc As PartDocument
oPartDoc = ThisApplication.ActiveDocument
oNamer = "Process name"
Dim UNDO As Transaction 
UNDO = ThisApplication.TransactionManager.StartTransaction(oPartDoc, oNamer)

Dim oCompDef As ComponentDefinition
oCompDef = ThisDoc.Document.ComponentDefinition
i = 0

For Each SurfaceBody In oCompDef.SurfaceBodies

Dim oBody As SurfaceBody
Dim oTransBRep As TransientBRep
oTransBRep = ThisApplication.TransientBRep
Dim oTransSolid As SurfaceBody
Dim oTransLump As FaceShell
i = i + 1
oBody = oCompDef.SurfaceBodies.Item(i)
oLumpsCount = oBody.FaceShells.Count

	oTransSolid = oTransBRep.Copy(oBody)
	Try
	oTransFaces = oTransSolid.FaceShells
	Catch
End Try
Try
	oTransLump = oTransFaces.Item(1)
	Dim facesToDelete As ObjectCollection
	facesToDelete = ThisApplication.TransientObjects.CreateFaceCollection
	Dim fc As Face

		For Each fc In oTransLump.Faces
		Call facesToDelete.Add(fc)
		Next

	oTransBRep.DeleteFaces(facesToDelete, False)
	facesToDelete.Clear

	oBox = oTransSolid.OrientedMinimumRangeBox
	oX = (Round(oBox.DirectionOne.Length, 2))*10 
	oY = (Round(oBox.DirectionTwo.Length, 2))*10
	oZ = (Round(oBox.DirectionThree.Length, 2)) * 10

	oTransSolid.Delete
	ooName = "___" & oLumpsCount.ToString & "x" & "[[" & oX.ToString & "mm x " & oY.ToString & "mm x " & oZ.ToString & "mm]]"
	oBody.Name = oBody.Name & ooName
	
Catch
End Try	
End If
End If
Next
UNDO.End

J-Camper · ‎10-06-2021

This is an example of what I ended up doing in order to fake the OrientedRangeBox for Faceshells:

Sub Main
	Dim pDoc As PartDocument = TryCast(ThisDoc.Document, PartDocument)
	If IsNothing(pDoc) Then Exit Sub
	
	Dim PickBody As SurfaceBody = ThisApplication.CommandManager.Pick(SelectionFilterEnum.kPartBodyFilter, "Select a Body")
	If IsNothing(PickBody) Then Exit Sub ' If nothing gets selected then we're done
	
	Dim BodyDescription As String = BuildDescription(pDoc.ComponentDefinition, PickBody)
	
	Logger.Trace(BodyDescription)
	
End Sub

Function BuildDescription(pDef As PartComponentDefinition, oSolid As SurfaceBody) As String
	Dim Result As String = Nothing
	Dim BoxCollection As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection
	If oSolid.FaceShells.Count > 1
		Logger.Trace("Multi body: " & oSolid.FaceShells.Count)
		For Each fs As FaceShell In oSolid.FaceShells
			'Define Objects to create transient copy
			Dim sbDef As SurfaceBodyDefinition = ThisApplication.TransientBRep.CreateSurfaceBodyDefinition 
			Dim lumpDef As LumpDefinition = sbDef.LumpDefinitions.Add()
			Dim fsDef As FaceShellDefinition = lumpDef.FaceShellDefinitions.Add()
			'Start to fill Definition
			For Each f As Face In fs.Faces
				Dim fDef As FaceDefinition = fsDef.FaceDefinitions.Add(f.Geometry, f.IsParamReversed)
				Dim elDef As EdgeLoopDefinition = fDef.EdgeLoopDefinitions.Add()
				For Each ed As Edge In f.EdgeLoops.Item(1).Edges
					elDef.EdgeUseDefinitions.Add(sbDef.EdgeDefinitions.Add(sbDef.VertexDefinitions.Add(ed.StartVertex.Point), sbDef.VertexDefinitions.Add(ed.StopVertex.Point), ed.Geometry), ed.IsParamReversed)
				Next
			Next
			'Body creation
			Dim oErrors As NameValueMap
			Dim TransBody As SurfaceBody = sbDef.CreateTransientSurfaceBody(oErrors)
			BoxCollection.Add(TransBody.OrientedMinimumRangeBox)
		Next
	Else If oSolid.FaceShells.Count = 1
		Logger.Trace("Single")
		BoxCollection.Add(oSolid.OrientedMinimumRangeBox)
	End If
	For Each ItemRangeBox As OrientedBox In BoxCollection
		Dim AddString As String = FormulateString(ItemRangeBox.DirectionOne.Length, ItemRangeBox.DirectionTwo.Length, ItemRangeBox.DirectionThree.Length)
		Result += AddString
	Next
	Return Result
End Function

Function FormulateString(DoubleX As Double, DoubleY As Double, DoubleZ As Double) As String
	'Logger.Trace("Formulating")
	Dim Result As String = Nothing
	Dim Length, Width, Thickness As Double
	Dim inchOutput As Double = 2.54
	Dim inc As Double = 1/64
	Dim dec As Integer = 9
	
	If DoubleX >= DoubleY And DoubleX >= DoubleZ
		Length = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
		If DoubleY >= DoubleZ
			Width = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
		Else
			Width = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
		End If
	Else If DoubleY >= DoubleX And DoubleY >= DoubleZ
		Length = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
		If DoubleX >= DoubleZ
			Width = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
		Else
			Width = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
		End If
	Else
		Length = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
		If DoubleX >= DoubleY
			Width = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
		Else
			Width = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
		End If
	End If
	
	Result = "(1) @ " & Length.ToString & """ x " & Width.ToString & """ x " & Thickness.ToString & ""","
		
	Return Result
End Function

The key was learning how to write existing faceshell data out for the FaceShellDefinition.

Let me know if you have any questions.

Stakin · ‎10-06-2021

it is great to solve。wanderful

william · ‎10-07-2021

Hello @josiah.fordCEEGJ & @J-Camper
Thanks for your posts. I havent had a chance to test them yet, but fully intend to do so once I get a spare time from production demands.
Looks like I should be able to get it to work with what youve shared.

william · ‎10-07-2021

Thank you. Modified code works nicely. See below/attached:

Dim oCompDef As ComponentDefinition
oCompDef = ThisDoc.Document.ComponentDefinition
doc = ThisDoc.Document 

i = 0

For Each SurfaceBody In oCompDef.SurfaceBodies
	Dim oBody As SurfaceBody
	Dim oTransBRep As TransientBRep
	oTransBRep = ThisApplication.TransientBRep
	Dim oTransSolid As SurfaceBody
	Dim oTransLump As FaceShell
	i = i + 1
	oBody = oCompDef.SurfaceBodies.Item(i)
	oLumpsCount = oBody.FaceShells.Count

	Try
		k = 1
		For j = 0 To oLumpsCount - 1
			oTransSolid = oTransBRep.Copy(oBody)
			oTransFaces = oTransSolid.FaceShells
			
			oTransLump = oTransFaces.Item(k)
			Dim facesToDelete As ObjectCollection
			facesToDelete = ThisApplication.TransientObjects.CreateFaceCollection
			Dim fc As Face

				For Each fc In oTransLump.Faces
					Call facesToDelete.Add(fc)
				Next
			
			oTransBRep.DeleteFaces(facesToDelete, False)
			facesToDelete.Clear

			oBox = oTransSolid.OrientedMinimumRangeBox
			oTransSolid.Delete
			
			Dim dir1 As Double = Round(oBox.DirectionOne.Length,2)
			Dim dir2 As Double = Round(oBox.DirectionTwo.Length,2)
			Dim dir3 As Double = Round(oBox.DirectionThree.Length,2)
			
			Dim uom As UnitsOfMeasure = doc.UnitsOfMeasure

			dir1 = uom.ConvertUnits(dir1, "cm", uom.LengthUnits)
			dir2 = uom.ConvertUnits(dir2, "cm", uom.LengthUnits)
			dir3 = uom.ConvertUnits(dir3, "cm", uom.LengthUnits)

			Dim lengths As New List(Of Double) From {dir1, dir2, dir3 }
			lengths.Sort

			Dim minLength As Double = lengths(0)
			Dim midLength As Double = lengths(1)
			Dim maxLength As Double = lengths(2)

			' Display minimum rangebox size.
			ooName = oBody.Name & " - Faceshell " & k & " : " & maxLength.ToString & "mm x " & midLength.ToString & "mm x " & minLength.ToString & "mm"
			MessageBox.Show(ooName, "Title")
			
			k = k + 1
		Next
	Catch
	End Try	
Next

The next step for me is to put that into an assembly, to run on a part file existing in assembly, and create a virtual component with the iproperties matching the length/width/thickness of the faceshell.

william · ‎10-11-2021

Ok I have made some progress with putting this into an assembly.

I am a bit stuck though, it gives errors in various places.

I get the messages with the correct number of faceshells, but then this error on the last component occurrence.

at System.RuntimeType.ForwardCallToInvokeMember(String memberName, BindingFlags flags, Object target, Int32[] aWrapperTypes, MessageData& msgData)
at Inventor.SurfaceBody.get_FaceShells()
at ThisRule.Main()
at Autodesk.iLogic.Exec.AppDomExec.ExecRuleInAssembly(Assembly assem)
at iLogic.RuleEvalContainer.ExecRuleEval(String execRule)

Also it is not getting the correct quantities on the bom.

@josiah.fordCEEGJ & @J-Camper -any ideas?

The code is pretty muddly, but hopefully the intent is clear enough.

Files attached. Hopefully this will be useful to someone else also.

'Rev 0 - 211012 - WI - Initial Issue

'Notes: 
'Solid body names must be named with the following method: REF_RAIL_ <insert solid body identifier here>
'The use of underscore for the seperator in the solid body name must be used. 

If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
    MessageBox.Show("This rule can only be run in an assembly environment" & vbNewLine & "The rule will exit...", "Error Handling",MessageBoxButtons.OK,MessageBoxIcon.Error)
    Return
End If

Dim oAsm As AssemblyDocument = ThisDoc.Document
Dim oMatrix As Matrix = ThisApplication.TransientGeometry.CreateMatrix
Dim oAsmCompDef As AssemblyComponentDefinition = ThisApplication.ActiveDocument.ComponentDefinition
Dim oOcc As ComponentOccurrence
Dim oOccs = oAsmCompDef.Occurrences
doc = ThisDoc.Document 
Dim MyArrayList As New ArrayList
Dim MyArrayQTY As New ArrayList

For Each oOcc In oAsmCompDef.Occurrences
	If TypeOf oOcc.Definition Is VirtualComponentDefinition Then
		If oOcc.Name.Contains("REF_RAIL") Then
			oOcc.Delete
	
		End If
	End If
Next


For Each oOcc In oAsmCompDef.Occurrences
	If TypeOf oOcc.Definition Is VirtualComponentDefinition Then
	Else
		Dim oCompDef As PartComponentDefinition = oOcc.Definition
		oDoc = oOcc.Definition.Document
		i = 0
		For Each SurfaceBody In oCompDef.SurfaceBodies
			Dim oBody As SurfaceBody
			i = i + 1
			oBody = oCompDef.SurfaceBodies.Item(i)
			If oBody.Name.Contains("REF_RAIL") Then
				Dim oTransBRep As TransientBRep
				oTransBRep = ThisApplication.TransientBRep
				Dim oTransSolid As SurfaceBody
				Dim oTransLump As FaceShell
				oLumpsCount = oBody.FaceShells.Count
				
					strParentDescription = iProperties.Value(oOcc.Name, "Project", "Description")
					strParentName = oDoc.FullFileName
					strSBName = oBody.Name
					strSBNameArray = strSBName.Split("_")
						Try
							strSolidBodyIdentifier = strSBNameArray(2)
						Catch
							strSolidBodyIdentifier = ""
						End Try
				
				MessageBox.Show(oBody.Name & " = " & oLumpsCount & " Faceshells","Error Checking")
				'Try
					k = 1
					If oLumpsCount <= 1 Then
						Counter = 0
					Else
						Counter = oLumpsCount - 1
					End If
					For j = 0 To Counter
						If oLumpsCount <= 1 Then
							oBox = oBody.OrientedMinimumRangeBox
						Else
							oTransSolid = oTransBRep.Copy(oBody)
							oTransFaces = oTransSolid.FaceShells
							oTransLump = oTransFaces.Item(k)
							Dim facesToDelete As ObjectCollection
							facesToDelete = ThisApplication.TransientObjects.CreateFaceCollection
							Dim fc As Face

								For Each fc In oTransLump.Faces
									Call facesToDelete.Add(fc)
								Next
							
							oTransBRep.DeleteFaces(facesToDelete, False)
							facesToDelete.Clear

							oBox = oTransSolid.OrientedMinimumRangeBox
							oTransSolid.Delete							
						End If

						
						Dim dir1 As Double = Round(oBox.DirectionOne.Length,2)
						Dim dir2 As Double = Round(oBox.DirectionTwo.Length,2)
						Dim dir3 As Double = Round(oBox.DirectionThree.Length,2)
						
						Dim uom As UnitsOfMeasure = doc.UnitsOfMeasure

						dir1 = uom.ConvertUnits(dir1, "cm", uom.LengthUnits)
						dir2 = uom.ConvertUnits(dir2, "cm", uom.LengthUnits)
						dir3 = uom.ConvertUnits(dir3, "cm", uom.LengthUnits)

						Dim lengths As New List(Of Double) From {dir1, dir2, dir3 }
						lengths.Sort

						Dim minLength As Double = lengths(0)
						Dim midLength As Double = lengths(1)
						Dim maxLength As Double = lengths(2)
						
						strDimensions = midLength.ToString & " X " & minLength.ToString & " - " & maxLength.ToString
						strArrayString = strDimensions & ";" & strParentDescription & ";" & strParentName & ";" & strSolidBodyIdentifier
						MyArrayList.Add(strArrayString)
						MyArrayQTY.Add(1)
						k = k + 1
					Next
				'Catch
				'End Try	
			End If
		Next
	End If
Next

''Error Checking code - to see what the array values are
'oWrite = System.IO.File.CreateText(ThisDoc.PathAndFileName(False) & ".txt")
'For i = 0 To MyArrayList.Count - 1
'	oWrite.WriteLine(MyArrayList.Item(i))
'Next
'oWrite.Close()
'ThisDoc.Launch(ThisDoc.PathAndFileName(False) & ".txt")

'Searching for duplicate entries in the array and removing them, also adding the qty's together for duplicates
For i = 0 To MyArrayList.Count - 1
Try
		ArraySearchItem = MyArrayList.Item(i)
		For j = 0 To MyArrayList.Count - 1
			
			Try
				
				If ArraySearchItem <> MyArrayList.Item(j) Then

				Else
					If i = j Then
						'Ignore
					Else
						MyArrayList.RemoveAt(j)
						MyArrayQTY(i) = MyArrayQTY(i) + MyArrayQTY(j)
						MyArrayQTY.RemoveAt(j)
'						MessageBox.Show("Duplicate found: " & _
'						vbNewLine & "MyArrayList.Item(" & i & ") = " & ArraySearchItem & _
'						vbNewLine & "MyArrayList.Item(" & j & ") = " & MyArrayList.Item(j) & _
'						vbNewLine & "MyArrayQTY(" & i & ") = " & MyArrayQTY(i), "Title")
					End If
				End If
			Catch
			End Try
		Next
		
	Catch
	End Try
Next

'MessageBox.Show(MyArrayList.Count)
'For i = 0 To MyArrayList.Count -1
'	MessageBox.Show(MyArrayList.Item(i) & vbNewLine & MyArrayQTY.Item(i))
'Next

For i = 0 To MyArrayList.Count - 1
	strSBNameArray = MyArrayList.Item(i).Split(";")
	strDimensions = strSBNameArray(0)
	strParentDescription = strSBNameArray(1)
	strParentName = strSBNameArray(2)
	strSolidBodyIdentifier = strSBNameArray(3)
	
	oOccVirt = oAsm.ComponentDefinition.Occurrences.AddVirtual("REF_RAIL " & i, oMatrix)
	strOccName = oOccVirt.Name
	iProperties.Value(strOccName, "Project", "Part Number") = "REF_RAIL " & i
	iProperties.Value(strOccName, "Project", "Stock Number") = strDimensions
	iProperties.Value(strOccName, "Project", "Description") = strSolidBodyIdentifier
	iProperties.Value(strOccName, "Custom", "Parent") = strParentDescription
	ThisBOM.OverrideQuantity("Model Data","REF_RAIL " & i,MyArrayQTY.Item(i))
Next

MyArrayList.Clear
MyArrayQTY.Clear

josiah.fordCEEGJ · ‎10-12-2021

@william I get the same error, even when just running in a single multi-body part, by all accounts it seems to fail on a selection of random solids, which changes every run. So in my case it's the line "

oTransFaces = oTransSolid.FaceShell

every time, this is the exact point where it fails, its like it can't find the faceshell, or is getting confused somewhere. So I wrote a try catch around a couple different parts which identifies the ones that error, leaves them alone except for marking them and then runs a seperate rule that goes through and targets only those solids...

The full stable (but still quite messy, I'm very much an amatuer) code is below.

Dim oPartDoc As PartDocument
oPartDoc = ThisApplication.ActiveDocument
oNamer = "MultiMeasure"
Dim UNDO As Transaction 
UNDO = ThisApplication.TransactionManager.StartTransaction(oPartDoc, oNamer)

Dim oCompDef As ComponentDefinition
oCompDef = ThisDoc.Document.ComponentDefinition
i = 0

For Each SurfaceBody In oCompDef.SurfaceBodies

Dim oBody As SurfaceBody
Dim oTransBRep As TransientBRep
oTransBRep = ThisApplication.TransientBRep
Dim oTransSolid As SurfaceBody
Dim oTransLump As FaceShell
i = i + 1
oBody = oCompDef.SurfaceBodies.Item(i)
oLumpsCount = oBody.FaceShells.Count
If Right(oBody.Name, 2) = "]]"
oBody.Name = Left(oBody.Name, oBody.Name.IndexOf("___"))
End If

If Left(oBody.Name, 1) = "'" Then

	If oLumpsCount < 2 Then

	oBox = oBody.OrientedMinimumRangeBox
	oX = (Round(oBox.DirectionOne.Length, 2))*10 
	oY = (Round(oBox.DirectionTwo.Length, 2))*10
	oZ = (Round(oBox.DirectionThree.Length, 2)) * 10
	ooName = "___1x[[" & oX.ToString & "mm x " & oY.ToString & "mm x " & oZ.ToString & "mm]]"
	oBody.Name = oBody.Name & ooName

	Else

	oTransSolid = oTransBRep.Copy(oBody)
	Try
	oTransFaces = oTransSolid.FaceShells
	Catch
	ooName = "___" & oLumpsCount.ToString & "x" & "[[ERROR]]"
	oBody.Name = oBody.Name & ooName
End Try
Try
	oTransLump = oTransFaces.Item(1)
	Dim facesToDelete As ObjectCollection
	facesToDelete = ThisApplication.TransientObjects.CreateFaceCollection
	Dim fc As Face

		For Each fc In oTransLump.Faces
		Call facesToDelete.Add(fc)
		Next

	oTransBRep.DeleteFaces(facesToDelete, False)
	facesToDelete.Clear

	oBox = oTransSolid.OrientedMinimumRangeBox
	oX = (Round(oBox.DirectionOne.Length, 2))*10 
	oY = (Round(oBox.DirectionTwo.Length, 2))*10
	oZ = (Round(oBox.DirectionThree.Length, 2)) * 10

	oTransSolid.Delete
	ooName = "___" & oLumpsCount.ToString & "x" & "[[" & oX.ToString & "mm x " & oY.ToString & "mm x " & oZ.ToString & "mm]]"
	oBody.Name = oBody.Name & ooName

Catch
End Try	
End If

Else If Left(oBody.Name, 1) = "#"
ooName = "___[[x" & oLumpsCount.ToString & "]]"
oBody.Name = oBody.Name & ooName
End If


Next

iLogicVb.RunExternalRule("Multi-Measure_ERRORS")

UNDO.End

and once that names the bodies it couldn't do on that run I run the slightly modified "Multi-Measure_ERRORS" code below.

Dim oPartDoc As PartDocument
oPartDoc = ThisApplication.ActiveDocument
oNamer = "Error-Catch"
Dim UNDO As Transaction 
UNDO = ThisApplication.TransactionManager.StartTransaction(oPartDoc, oNamer)

Dim oCompDef As ComponentDefinition
oCompDef = ThisDoc.Document.ComponentDefinition
i = 0

For Each SurfaceBody In oCompDef.SurfaceBodies

Dim oBody As SurfaceBody
Dim oTransBRep As TransientBRep
oTransBRep = ThisApplication.TransientBRep
Dim oTransSolid As SurfaceBody
Dim oTransLump As FaceShell
i = i + 1
oBody = oCompDef.SurfaceBodies.Item(i)
oLumpsCount = oBody.FaceShells.Count

If Right(oBody.Name, 9) = "[[ERROR]]"

	oTransSolid = oTransBRep.Copy(oBody)
	Try
	oTransFaces = oTransSolid.FaceShells
	Catch
	oBody.Name = Left(oBody.Name, oBody.Name.IndexOf("___"))
	ooName = "___" & oLumpsCount.ToString & "x" & "[[ERROR]]"
	oBody.Name = oBody.Name & ooName

End Try
Try

	oTransLump = oTransFaces.Item(1)
	Dim facesToDelete As ObjectCollection
	facesToDelete = ThisApplication.TransientObjects.CreateFaceCollection
	Dim fc As Face

		For Each fc In oTransLump.Faces
		Call facesToDelete.Add(fc)
		Next

	oTransBRep.DeleteFaces(facesToDelete, False)
	facesToDelete.Clear

	oBox = oTransSolid.OrientedMinimumRangeBox
	oX = (Round(oBox.DirectionOne.Length, 2))*10 
	oY = (Round(oBox.DirectionTwo.Length, 2))*10
	oZ = (Round(oBox.DirectionThree.Length, 2)) * 10

	oTransSolid.Delete
	oBody.Name = Left(oBody.Name, oBody.Name.IndexOf("___"))
	ooName = "___" & oLumpsCount.ToString & "x" & "[[" & oX.ToString & "mm x " & oY.ToString & "mm x " & oZ.ToString & "mm]]"
	oBody.Name = oBody.Name & ooName

Catch
End Try	

End If

Next

UNDO.End

and that usually cleans up all the ones it couldn't on the first run. As I said it seems to randomly error and so this method has been working perfectly for me on a few very different models. There is definitely a way to combine the codes together to run as one, but I haven't had the chance to colate them yet.

Hope this helps! I only figured this out fully and got it stable last week!

J-Camper · ‎10-12-2021

I was getting issues with some bodies, I think the combine cut feature was a problem i identified, when I was still trying to use the delete face method. The transient body creation method i posted earlier is much more robust then the delete face method. I'm currently using it in my own custom rules.

Here is a bit of an extension to the code i posted before, where it will run in part or assembly:

Sub Main
	
	Dim aDoc As AssemblyDocument = TryCast(ThisApplication.ActiveDocument, AssemblyDocument)
	If Not IsNothing(aDoc) Then Call AssemblyEnvironment(aDoc)
	
	Dim pDoc As PartDocument = TryCast(ThisDoc.Document, PartDocument)
	If Not IsNothing(pDoc) Then Call PartEnvironment(pDoc)
	
End Sub

Sub AssemblyEnvironment(oDoc As AssemblyDocument)
Selection:	  
	Dim PickCO As ComponentOccurrence = ThisApplication.CommandManager.Pick(SelectionFilterEnum.kAssemblyLeafOccurrenceFilter, "Select Part with body to extract")
	If IsNothing(PickCO) Then Exit Sub ' If nothing gets selected then we're done
	If PickCO.Definition.Document.DocumentType <> kPartDocumentObject Then If MessageBox.Show("Selected Occurence is not a part document.  Would you like to pick a different occurrence?", "Re-Pick?", MessageBoxButtons.YesNo) = vbYes Then GoTo Selection Else Exit Sub
	
	Dim pDef As PartComponentDefinition = PickCO.Definition
	Dim solidList As New List(Of String)
	Dim Correspondence As New List (Of Integer)
	
	For Each b As SurfaceBody In pDef.SurfaceBodies
		solidList.Add(b.Name & ":" & solidList.Count+1)
	Next
	
	If solidList.Count < 1 Then Logger.Trace("No Solids") : Exit Sub
	Dim pickedName As String = InputListBox("Select a Body to extract for Purchase List", solidList, solidList.Item(0), Title := "Solid Body Selection", ListName := "Available Bodies")
	If IsNothing(pickedName) Then Logger.Trace("No Selection") : Exit Sub
	
	Dim bodyIndex As Integer = CInt(Right(pickedName, pickedName.Length - pickedName.LastIndexOf(":") -1))
	
	Dim PickedSolid As SurfaceBody = pDef.SurfaceBodies.Item(bodyIndex)
	
	Dim BodyDescription As String = BuildDescription(pDef, PickedSolid)
	Logger.Trace(BodyDescription)
	
End Sub

Sub PartEnvironment(oDoc As PartDocument)
	
	Dim PickBody As SurfaceBody = ThisApplication.CommandManager.Pick(SelectionFilterEnum.kPartBodyFilter, "Select a Body")
	If IsNothing(PickBody) Then Exit Sub ' If nothing gets selected then we're done
	
	Dim BodyDescription As String = BuildDescription(oDoc.ComponentDefinition, PickBody)
	Logger.Trace(BodyDescription)
	
End Sub

Function BuildDescription(pDef As PartComponentDefinition, oSolid As SurfaceBody) As String
	Dim Result As String = Nothing
	Dim BoxCollection As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection
	If oSolid.FaceShells.Count > 1
		Logger.Trace("Multi body: " & oSolid.FaceShells.Count)
		For Each fs As FaceShell In oSolid.FaceShells
			'Define Objects to create transient copy
			Dim sbDef As SurfaceBodyDefinition = ThisApplication.TransientBRep.CreateSurfaceBodyDefinition 
			Dim lumpDef As LumpDefinition = sbDef.LumpDefinitions.Add()
			Dim fsDef As FaceShellDefinition = lumpDef.FaceShellDefinitions.Add()
			'Start to fill Definition
			For Each f As Face In fs.Faces
				Dim fDef As FaceDefinition = fsDef.FaceDefinitions.Add(f.Geometry, f.IsParamReversed)
				Dim elDef As EdgeLoopDefinition = fDef.EdgeLoopDefinitions.Add()
				For Each ed As Edge In f.EdgeLoops.Item(1).Edges
					elDef.EdgeUseDefinitions.Add(sbDef.EdgeDefinitions.Add(sbDef.VertexDefinitions.Add(ed.StartVertex.Point), sbDef.VertexDefinitions.Add(ed.StopVertex.Point), ed.Geometry), ed.IsParamReversed)
				Next
			Next
			'Body creation
			Dim oErrors As NameValueMap
			Dim TransBody As SurfaceBody = sbDef.CreateTransientSurfaceBody(oErrors)
			BoxCollection.Add(TransBody.OrientedMinimumRangeBox)
		Next
	Else If oSolid.FaceShells.Count = 1
		Logger.Trace("Single")
		BoxCollection.Add(oSolid.OrientedMinimumRangeBox)
	End If
	For Each ItemRangeBox As OrientedBox In BoxCollection
		Dim AddString As String = FormulateString(ItemRangeBox.DirectionOne.Length, ItemRangeBox.DirectionTwo.Length, ItemRangeBox.DirectionThree.Length)
		Result += AddString
	Next
	Return Result
End Function

Function FormulateString(DoubleX As Double, DoubleY As Double, DoubleZ As Double) As String
	'Logger.Trace("Formulating")
	Dim Result As String = Nothing
	Dim Length, Width, Thickness As Double
	Dim inchOutput As Double = 2.54
	Dim inc As Double = 1/64
	Dim dec As Integer = 9
	
	If DoubleX >= DoubleY And DoubleX >= DoubleZ
		Length = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
		If DoubleY >= DoubleZ
			Width = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
		Else
			Width = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
		End If
	Else If DoubleY >= DoubleX And DoubleY >= DoubleZ
		Length = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
		If DoubleX >= DoubleZ
			Width = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
		Else
			Width = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
		End If
	Else
		Length = Math.Round(Math.Round((DoubleZ / inchOutput),dec)/inc)*inc
		If DoubleX >= DoubleY
			Width = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
		Else
			Width = Math.Round(Math.Round((DoubleY / inchOutput),dec)/inc)*inc
			Thickness = Math.Round(Math.Round((DoubleX / inchOutput),dec)/inc)*inc
		End If
	End If
	
	Result = "(1) @ " & Length.ToString & """ x " & Width.ToString & """ x " & Thickness.ToString & ""","
		
	Return Result
End Function

The occurrence & body selection methods can be changed to a loop if desired and I'm currently just outputting a single string with the dimensions of each faceshell. You will have to implement your actual reporting method, but it should be pretty easy.

If you have any questions, please let me know.

william · ‎10-13-2021

Thanks.

Working well. Should save a lot of time, not having to manually detail cutlists.

Your pointers on the transient body creation method removed the instability with the delete face method.

Code below.

'Rev 0 - 211012 - WI - Initial Issue

'Notes: 
'Solid body names must be named with the following method: REF_RAIL_ <insert solid body identifier here>
'The use of underscore for the seperator in the solid body name must be used. 

If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject Then
    MessageBox.Show("This rule can only be run in an assembly environment" & vbNewLine & "The rule will exit...", "Error Handling",MessageBoxButtons.OK,MessageBoxIcon.Error)
    Return
End If

Dim oAsm As AssemblyDocument = ThisDoc.Document
Dim oMatrix As Matrix = ThisApplication.TransientGeometry.CreateMatrix
Dim oAsmCompDef As AssemblyComponentDefinition = ThisApplication.ActiveDocument.ComponentDefinition
Dim oOcc As ComponentOccurrence
Dim oOccs = oAsmCompDef.Occurrences
doc = ThisDoc.Document 
Dim MyArrayList As New ArrayList
Dim MyArrayQTY As New ArrayList
Dim MyArrayDeleteList As New ArrayList

For Each oOcc In oAsmCompDef.Occurrences
	If TypeOf oOcc.Definition Is VirtualComponentDefinition Then
		If oOcc.Name.Contains("REF_RAIL") Then
			oOcc.Delete
	
		End If
	End If
Next


For Each oOcc In oAsmCompDef.Occurrences
	If TypeOf oOcc.Definition Is VirtualComponentDefinition Then
	Else
		If oOcc.BOMStructure = kReferenceBOMStructure
			'Ignore parts with Bom set to reference
		Else
			Dim oCompDef As PartComponentDefinition = oOcc.Definition
			oDoc = oOcc.Definition.Document
			i = 0
			For Each SurfaceBody In oCompDef.SurfaceBodies
				Dim oBody As SurfaceBody
				i = i + 1
				oBody = oCompDef.SurfaceBodies.Item(i)
				If oBody.Name.Contains("REF_RAIL") Then
					strParentDescription = iProperties.Value(oOcc.Name, "Project", "Description")
					strParentName = oDoc.FullFileName
					strSBName = oBody.Name
					strSBNameArray = strSBName.Split("_")
						Try
							strSolidBodyIdentifier = strSBNameArray(2)
						Catch
							strSolidBodyIdentifier = ""
						End Try
							Dim BoxCollection As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection
								For Each fs As FaceShell In oBody.FaceShells
									Dim sbDef As SurfaceBodyDefinition = ThisApplication.TransientBRep.CreateSurfaceBodyDefinition 
									Dim lumpDef As LumpDefinition = sbDef.LumpDefinitions.Add()
									Dim fsDef As FaceShellDefinition = lumpDef.FaceShellDefinitions.Add()
										For Each f As Face In fs.Faces
											Dim fDef As FaceDefinition = fsDef.FaceDefinitions.Add(f.Geometry, f.IsParamReversed)
											Dim elDef As EdgeLoopDefinition = fDef.EdgeLoopDefinitions.Add()
												For Each ed As Edge In f.EdgeLoops.Item(1).Edges
													elDef.EdgeUseDefinitions.Add(sbDef.EdgeDefinitions.Add(sbDef.VertexDefinitions.Add(ed.StartVertex.Point), sbDef.VertexDefinitions.Add(ed.StopVertex.Point), ed.Geometry), ed.IsParamReversed)
												Next
										Next
									Dim oErrors As NameValueMap
									Dim TransBody As SurfaceBody = sbDef.CreateTransientSurfaceBody(oErrors)
									BoxCollection.Add(TransBody.OrientedMinimumRangeBox)
								Next
						For Each ItemRangeBox As OrientedBox In BoxCollection
							Dim dir1 As Double = Round(ItemRangeBox.DirectionOne.Length,2)
							Dim dir2 As Double = Round(ItemRangeBox.DirectionTwo.Length,2)
							Dim dir3 As Double = Round(ItemRangeBox.DirectionThree.Length,2)
							
							Dim uom As UnitsOfMeasure = doc.UnitsOfMeasure

							dir1 = uom.ConvertUnits(dir1, "cm", uom.LengthUnits)
							dir2 = uom.ConvertUnits(dir2, "cm", uom.LengthUnits)
							dir3 = uom.ConvertUnits(dir3, "cm", uom.LengthUnits)

							Dim lengths As New List(Of Double) From {dir1, dir2, dir3 }
							lengths.Sort

							Dim minLength As Double = lengths(0)
							Dim midLength As Double = lengths(1)
							Dim maxLength As Double = lengths(2)
							
							strDimensions = midLength.ToString & " X " & minLength.ToString & " - " & maxLength.ToString
							strArrayString = strDimensions & ";" & strParentDescription & ";" & strParentName & ";" & strSolidBodyIdentifier
							MyArrayList.Add(strArrayString)
							MyArrayQTY.Add(1)
						Next	
				End If
			Next
		End If
	End If
Next

MyArrayList.Sort()
	For i = 0 To MyArrayList.Count - 1
		If i = 0
		Else
			If MyArrayList(i) = MyArrayList(i - 1) Then
				MyArrayDeleteList.Add(i-1)
				MyArrayQTY(i) = MyArrayQTY(i) + MyArrayQTY(i-1)
			Else
			End If
		End If
	Next
		For i = 0 To MyArrayDeleteList.Count - 1
			MyArrayList.Item(MyArrayDeleteList(i)) = "Delete"
			MyArrayQTY.Item(MyArrayDeleteList(i)) = "Delete"
		Next
			For i = (MyArrayList.Count - 1) To 0 Step -1
				If MyArrayList(i) = "Delete" Then
					MyArrayList.RemoveAt(i)
					MyArrayQTY.RemoveAt(i)
				End If
			Next

''Error Checking code - to see what the array values are
'oWrite = System.IO.File.CreateText(ThisDoc.PathAndFileName(False) & ".txt")
'For i = 0 To MyArrayList.Count - 1
'	oWrite.WriteLine(MyArrayQTY(i) & " X " & MyArrayList.Item(i))
'Next
'oWrite.Close()
'ThisDoc.Launch(ThisDoc.PathAndFileName(False) & ".txt")

For i = 0 To MyArrayList.Count - 1
	strSBNameArray = MyArrayList.Item(i).Split(";")
	strDimensions = strSBNameArray(0)
	strParentDescription = strSBNameArray(1)
	strParentName = strSBNameArray(2)
	strSolidBodyIdentifier = strSBNameArray(3)
	
	oOccVirt = oAsm.ComponentDefinition.Occurrences.AddVirtual("REF_RAIL " & i, oMatrix)
	strOccName = oOccVirt.Name
	iProperties.Value(strOccName, "Project", "Part Number") = "REF_RAIL " & i
	iProperties.Value(strOccName, "Project", "Stock Number") = strDimensions
	iProperties.Value(strOccName, "Project", "Description") = strSolidBodyIdentifier
	iProperties.Value(strOccName, "Custom", "Parent") = strParentDescription
	ThisBOM.OverrideQuantity("Model Data","REF_RAIL " & i,MyArrayQTY.Item(i))
Next

MyArrayList.Clear
MyArrayQTY.Clear

Community

Orientated Minimum Rangebox for Solid Body Faceshell

Orientated Minimum Rangebox for Solid Body Faceshell

Orientated Minimum Rangebox for Solid Body Faceshell