Thank you so much! This worked exactly how I wanted it to. I just had to add a few lines to name the parts how I needed them and save the resulting assembly how I wanted it. I also needed to set the display name to be the same as the file name for the parts. Thank you!
A quick question though, whenever I tried to run your code, I would get an error message that would say something like "Let and Set are not supported anymore." I had to remove the word Set from any lines that contained it and then it ran perfectly. Why is this? Anyways, thank you so much you've saved me hours of busy work.
Here is my final code, for anyone interested:
Sub Main()
' set a reference to the active partdocument
Dim prt As PartDocument
'Set prt = ThisApplication.ActiveDocument
prt = ThisApplication.ActiveDocument
Dim template As String
Dim folder As String
template = "F:\Drafting & Design\The Box\Inventor\Templates\Standard.ipt"
folder = PathName(prt.fullFileName)
Dim parname As String
parname = ThisDoc.FileName(False) 'without extension
' create an object collection to store the parts to put in assembly
Dim prtCol As ObjectCollection
prtCol = ThisApplication.TransientObjects.CreateObjectCollection
Dim a As Integer: a = 0
Dim suffix As String
' loop through the filtered selection
Dim sb As SurfaceBody
For Each sb In prt.ComponentDefinition.SurfaceBodies
' create a new part to derive the solid body in
Dim newPart As PartDocument
newPart = ThisApplication.Documents.Add(kPartDocumentObject, template, True)
' set a reference to the derivedpartcomponents
Dim dpcs As DerivedPartComponents
dpcs = newPart.ComponentDefinition.ReferenceComponents.DerivedPartComponents
' create the scale definition
Dim dpd As DerivedPartUniformScaleDef
dpd = dpcs.CreateUniformScaleDef(prt.fullFileName)
' set the settings in another sub
Call settingsDerivedPart(dpd, sb)
Call dpcs.Add(dpd)
Call prtCol.Add(newPart)
' set the part title to the solidbodies name
newPart.PropertySets.Item("Inventor Summary Information").Item("Title").Value = sb.Name 'sb.CreatedByFeature.Name
a = a + 1
If a = 1
suffix = "WEB"
End If
If a = 2
suffix = "TF"
End If
If a = 3
suffix = "BF"
End If
' Save the part
ThisApplication.SilentOperation = True
Call newPart.SaveAs(folder & parname & " " & suffix & ".ipt", False)
newpart.DisplayName = parname & " " & suffix
ThisApplication.SilentOperation = False
Next sb
'Create a new assembly to put parts in
Dim asm As AssemblyDocument
asm = ThisApplication.Documents.Add(kAssemblyDocumentObject)
' place in assembly
prt = Nothing
For Each prt In prtCol
' create an empty matrix
Dim mx As Matrix
'Set mx = ThisApplication.TransientGeometry.CreateMatrix()
mx = ThisApplication.TransientGeometry.CreateMatrix()
Dim occ As ComponentOccurrence
occ = asm.ComponentDefinition.Occurrences.AddByComponentDefinition(prt.ComponentDefinition, mx)
Call prt.Close(True)
Next
'Save assembly in same folder and with same name as parent file
Call asm.SaveAs(folder & parname & ".iam", False)
End Sub
Function PathName(FullPath As String) As String
' return all left of last \
PathName = Left(FullPath, InStrRev(FullPath, "\"))
End Function
Sub settingsDerivedPart(ByRef dpd As DerivedPartUniformScaleDef, sb As SurfaceBody)
' set the derive style
'dpd.DeriveStyle = kDeriveAsSingleBodyNoSeams
'dpd.UseColorOverridesFromSource = False
Call dpd.ExcludeAll
' include solid, exclude the others
Dim dpe As DerivedPartEntity
For Each dpe In dpd.Solids
If dpe.ReferencedEntity.Name = sb.Name Then
dpe.IncludeEntity = True
End If
Next
End Sub
