CAD Forum

Code: Select all

Option Explicit

' Name of the custom properties for body name
Const CustomPropName As String = "PARTNUMBER"

' Make this True if you want to collect identical bodies
Const CollectIdenticalBodies As Boolean = False

Sub main()
    
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swModelExt As SldWorks.ModelDocExtension
    Dim swFeat As SldWorks.Feature
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then End
    Set swModelExt = swModel.Extension
    
    ' Insert weldment feature if model isn't a weldment
    If Not swModel.IsWeldment Then swModel.FeatureManager.InsertWeldmentFeature
    
    ' DOCUMENT PROPERTIES - WELDMENT OPTIONS
    ' Toggle on creating cut list automaticly
    swModelExt.SetUserPreferenceToggle swUserPreferenceToggle_e.swWeldmentEnableAutomaticCutList, Empty, True
    ' Toggle off automatically renaming cut list folders using the Description property value
    swModelExt.SetUserPreferenceToggle swUserPreferenceToggle_e.swWeldmentRenameCutlistDescriptionPropertyValue, Empty, False
    ' Toggle collect identical bodies On/Off
    swModelExt.SetUserPreferenceToggle swUserPreferenceToggle_e.swWeldmentCollectIdenticalBodies, Empty, CollectIdenticalBodies
    
    ' Loop through cut-list folder
    Set swFeat = swModel.FirstFeature
    LoopThroughCutListFolder swFeat

End Sub

' Loop though cut-list folder
Sub LoopThroughCutListFolder(thisFeat As SldWorks.Feature)
    Dim subfeat As SldWorks.Feature
    While Not thisFeat Is Nothing
        If thisFeat.Name = "Solid Bodies" Then
            ' Update Cut List
            thisFeat.GetSpecificFeature2.UpdateCutList
            Set subfeat = thisFeat.GetFirstSubFeature
            While Not subfeat Is Nothing
                ' If subfeat is a cut-list folder then do the work
                If subfeat.GetTypeName = "CutListFolder" Then
                    DoTheWork subfeat
                End If
                Set subfeat = subfeat.GetNextSubFeature
            Wend
        End If
        Set thisFeat = thisFeat.GetNextFeature
    Wend
End Sub

' Rename cut-list-item folder to body name
' and copy body name to custom cut-list-item properties
Sub DoTheWork(thisFeat As SldWorks.Feature)
    
    Dim CustomPropMgr As SldWorks.CustomPropertyManager
    Dim BodyFolder As SldWorks.BodyFolder
    Dim swBody As SldWorks.Body2
    Dim BodyCount As Long
    
    Set BodyFolder = thisFeat.GetSpecificFeature2
    If BodyFolder Is Nothing Then Exit Sub
    
    ' Get first Body in folder
    Set swBody = BodyFolder.GetBodies(0)
    
    ' Rename Cut-List-Item folder to body name
    thisFeat.Name = swBody.Name & " "
    
    ' Add custom propertie
    Set CustomPropMgr = thisFeat.CustomPropertyManager
    CustomPropMgr.Add3 CustomPropName, swCustomInfoType_e.swCustomInfoText, _
                       swBody.Name, _
                       swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd
    
End Sub