So you have your sculpt feature and need to do the body cut next. Are you going to create a cut plane from scratch or set up a template file to load your mesh into?
I actually spent a little time the other night trying to get a mesh patching Function to work, because I have never done it before and was curious. I can find the a hole and patch it but get an error trying to redo the sculpt with 2 SculptSurfaces In the SurfCol Object Collection. The code below is what I was working on along with a Sub Routine to Split the sculpted body:
Sub Main
If ThisApplication.ActiveDocumentType <> kPartDocumentObject Then MessageBox.Show("This rule is designed to only work in part documents.", "Wrong Document Type") : Exit Sub
'I'm separating the code so it is easy to add to other code
Call MeshProcessing(ThisApplication.ActiveDocument)
End Sub
Sub MeshProcessing(pDoc As PartDocument)
Dim pDef As PartComponentDefinition = pDoc.ComponentDefinition
Dim SurfCol As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection
Dim NewSculptSurf As SculptSurface = pDef.Features.SculptFeatures.CreateSculptSurface(pDef.WorkSurfaces.Item(1), PartFeatureExtentDirectionEnum.kSymmetricExtentDirection)
SurfCol.Add(NewSculptSurf)
'Setup new ScupltFeature
Dim FirstPass As Boolean = True
Dim newSculpt As SculptFeature
Sculpting :
newSculpt = pDef.Features.SculptFeatures.Add(SurfCol, PartFeatureOperationEnum.kNewBodyOperation)
'Verify Scuplt has volume
If newSculpt.SurfaceBodies.Item(1).Volume(0.0001) > 0
MessageBox.Show("Scuplt did create a solid body.", "New Body! :)")
'Now we can split the body
Dim OurNewBody As SurfaceBody = newSculpt.SurfaceBodies.Item(1)
Call SplitThis(OurNewBody, pDef)
Else If FirstPass = True
FirstPass = False
MessageBox.Show("Scuplt Did not create a solid body. Sculpt feature will be removed.", "No New Body :(")
MessageBox.Show("I found " & MyCustomFunction(SurfCol.Item(1).Surface, pDef).Count & " to fill holes in mesh, but currently failing to implement.", "Unfinished Processing")
'I can find and make a Patch but Struggling with encorperating it with failed surface
'So I'm skipping the next section
GoTo SkipForNow
'newSculpt.Delete() 'Currently unsure if it is better to add surfaces to an existing scuplt or figure out what the new scuplt is failing with 2 SculptSurfaces
For Each Item In MyCustomFunction(SurfCol.Item(1).Surface, pDef)
SurfCol.Add(pDef.Features.SculptFeatures.CreateSculptSurface(Item, PartFeatureExtentDirectionEnum.kSymmetricExtentDirection))
'newSculpt.Surfaces.Add(pDef.Features.SculptFeatures.CreateSculptSurface(Item, PartFeatureExtentDirectionEnum.kSymmetricExtentDirection))
Next
GoTo Sculpting
SkipForNow:
Else
MessageBox.Show("I tried once to close the mesh but it didn't work.", "I Failed :(")
Exit Sub
End If
End Sub
Sub SplitThis(Body As SurfaceBody, Def As PartComponentDefinition)
'Dim TempDef As PartComponentDefinition
'TempDef.Features.SplitFeatures.TrimSolid(CutPlane, Body, True)
Dim CutPlane As WorkPlane
'Find existing:
For Each wkPlane As WorkPlane In Def.WorkPlanes
If wkPlane.Name = "CutPlane" 'Or what ever name you want to use for the work plane
CutPlane = wkPlane
End If
Next
'Check if we have a Plane
If IsNothing(CutPlane)
CutPlane = Def.WorkPlanes.AddByPlaneAndOffset(Def.WorkPlanes.Item(3), "50 mm", False) 'Plane 3 is XY Plane
CutPlane.Name = "CutPlane"
End If
'Now we have our Plane and body
Dim NewSplitFeat As SplitFeature = Def.Features.SplitFeatures.TrimSolid(CutPlane, Body, True)
End Sub
Function MyCustomFunction(wrkSurf As WorkSurface, Def As PartComponentDefinition) As ObjectCollection
'Setup
Dim Result As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection
Dim oneFaceEdges As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection
Dim BoundaryPatchDef As BoundaryPatchDefinition = Def.Features.BoundaryPatchFeatures.CreateBoundaryPatchDefinition()
Dim BoundaryPatchFeat As BoundaryPatchFeature
CheckEdgeLoops :
For Each ed As Edge In wrkSurf.SurfaceBodies.Item(1).Edges
If ed.Faces.Count = 1 Then oneFaceEdges.Add(ed)
Next
'MessageBox.Show(oneFaceEdges.Count, "Edges on 1 Face")
'Sketch for boundaries
Dim sk As Sketch3D = Def.Sketches3D.Add()
sk.Edit
For Each Item In oneFaceEdges
sk.Include(Item).Construction = False
Next
sk.Profiles3D.AddClosed
'MessageBox.Show(sk.Profiles3D.Count, "Title")
sk.ExitEdit
'Patch from sketch
For Each Prof As Profile3D In sk.Profiles3D
BoundaryPatchDef.BoundaryPatchLoops.Add(Prof)
BoundaryPatchFeat = Def.Features.BoundaryPatchFeatures.Add(BoundaryPatchDef)
For Each newSurf As WorkSurface In Def.WorkSurfaces
If newSurf.SurfaceBodies.Item(1).CreatedByFeature.ExtendedName = BoundaryPatchFeat.ExtendedName Then Result.Add(newSurf) : Exit For
Next
Next
'MessageBox.Show(Result.Count, "Title")
Return Result
End Function
I put the whole mesh Processing bit of code, which I posted earlier, into a sub routine so it is easy to incorporate with what ever rule you want.
I tested the Split and it is working, but let me know if you have any questions or need help with anything else along the road.
