Rename sheet metal flat patterns features after the cut-list features

Edit ArticleEdit Article
More 'Goodies'

Cut-lists and sheet metal flat patterns
Cut-lists and sheet metal flat patterns

This VBA macro renames all sheet metal flat pattern features with the name of the corresponding cut-list item.

This macro can be used in conjunction with Rename Cut List Features macro.

In order to avoid the name conflict, suffix is added to flat pattern features as below.

Const SUFFIX As String = "_FP"

Macro will automatically add the index to the flat pattern name which shares the same cut list.

Watch video demonstration

Const SUFFIX As String = "_FP"

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    On Error GoTo catch_
    Dim vCutListFeats As Variant
    vCutListFeats = GetCutListFeatures(swModel)
    If Not IsEmpty(vCutListFeats) Then
        Dim vFlatPatternFeats As Variant
        vFlatPatternFeats = GetFlatPatternFeatures(swModel)
        If Not IsEmpty(vFlatPatternFeats) Then
            RenameFlatPatternsWithCutList swModel, vFlatPatternFeats, vCutListFeats
            Err.Raise vbError, "", "No flat pattern features found"
        End If
        Err.Raise vbError, "", "No cut-list items found"
    End If
    GoTo finally_
    swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk

End Sub

Function GetCutListFeatures(model As SldWorks.ModelDoc2) As Variant
    GetCutListFeatures = GetFeaturesByType(model, "CutListFolder")
End Function

Function GetFlatPatternFeatures(model As SldWorks.ModelDoc2) As Variant
    GetFlatPatternFeatures = GetFeaturesByType(model, "FlatPattern")
End Function

Function RenameFlatPatternsWithCutList(model As SldWorks.ModelDoc2, vFlatPatternFeats As Variant, vCutListFeats As Variant)
    Dim i As Integer
    For i = 0 To UBound(vFlatPatternFeats)
        Dim swFlatPatternFeat As SldWorks.Feature
        Dim swFlatPattern As SldWorks.FlatPatternFeatureData
        Set swFlatPatternFeat = vFlatPatternFeats(i)
        Set swFlatPattern = swFlatPatternFeat.GetDefinition
        Dim swFixedFace As SldWorks.Face2
        Set swFixedFace = swFlatPattern.FixedFace2
        Dim swBody As SldWorks.Body2
        Set swBody = swFixedFace.GetBody
        Dim swCutListFeat As SldWorks.Feature
        Set swCutListFeat = FindCutListFeature(vCutListFeats, swBody)
        If Not swCutListFeat Is Nothing Then
            If swFlatPatternFeat.Name <> swCutListFeat.Name Then
                Dim featName As String
                featName = swCutListFeat.Name + SUFFIX
                Dim index As Integer
                index = 0
                While model.FeatureManager.IsNameUsed(swNameType_e.swFeatureName, featName)
                    index = index + 1
                    featName = swCutListFeat.Name + CStr(index) + SUFFIX
                swFlatPatternFeat.Name = featName
            End If
        End If
End Function

Function FindCutListFeature(vCutListFeats As Variant, body As SldWorks.Body2) As SldWorks.Feature
    Dim i As Integer
    For i = 0 To UBound(vCutListFeats)
        Dim swCutListFeat As SldWorks.Feature
        Set swCutListFeat = vCutListFeats(i)
        Dim swBodyFolder As SldWorks.BodyFolder
        Set swBodyFolder = swCutListFeat.GetSpecificFeature2
        Dim vBodies As Variant
        vBodies = swBodyFolder.GetBodies
        If ContainsBody(vBodies, body) Then
            Set FindCutListFeature = swCutListFeat
        End If
End Function

Function ContainsBody(vBodies As Variant, body As SldWorks.Body2) As Boolean
    If Not IsEmpty(vBodies) Then
        Dim i As Integer
        For i = 0 To UBound(vBodies)
            Dim swCutListBody As SldWorks.Body2
            Set swCutListBody = vBodies(i)
            If swApp.IsSame(swCutListBody, body) = swObjectEquality.swObjectSame Then
                ContainsBody = True
                Exit Function
            End If
    End If
    ContainsBody = False
End Function

Function GetFeaturesByType(model As SldWorks.ModelDoc2, typeName As String) As Variant
    Dim swFeats() As SldWorks.Feature
    Dim swFeat As SldWorks.Feature
    Set swFeat = model.FirstFeature
    Do While Not swFeat Is Nothing
        ProcessFeature swFeat, swFeats, typeName

        Set swFeat = swFeat.GetNextFeature
    If (Not swFeats) = -1 Then
        GetFeaturesByType = Empty
        GetFeaturesByType = swFeats
    End If
End Function

Sub ProcessFeature(thisFeat As SldWorks.Feature, featsArr() As SldWorks.Feature, typeName As String)
    If thisFeat.GetTypeName2() = typeName Then
        If (Not featsArr) = -1 Then
            ReDim featsArr(0)
            Set featsArr(0) = thisFeat
            Dim i As Integer
            For i = 0 To UBound(featsArr)
                If swApp.IsSame(featsArr(i), thisFeat) = swObjectEquality.swObjectSame Then
                    Exit Sub
                End If
            ReDim Preserve featsArr(UBound(featsArr) + 1)
            Set featsArr(UBound(featsArr)) = thisFeat
        End If
    End If
    Dim swSubFeat As SldWorks.Feature
    Set swSubFeat = thisFeat.GetFirstSubFeature
    While Not swSubFeat Is Nothing
        ProcessFeature swSubFeat, featsArr, typeName
        Set swSubFeat = swSubFeat.GetNextSubFeature
End Sub

Product of Xarial Product of Xarial