Rename cut list features based on custom properties using SOLIDWORKS API

Edit ArticleEdit Article
More 'Goodies'

Sheet metal cut list features
Sheet metal cut list features

This VBA macro allows to rename all cut list features for weldment and sheet metal part based on the name template which can include values of file and cut-list custom properties, file name, configuration name and free text.

Cut list properties
Cut list properties

To configure the macro modify the values of NAME_TEMPLATE, INDEX_FORMAT and ALWAYS_ADD_INDEX constants

NAME_TEMPLATE can contain free text and placeholders which will be dynamically replaced by corresponding custom properties values

The following placeholders are supported

  • <_FileName_> - name of the part file (without extension) where the cut-list resides in
  • <_ConfName_> - name of the active configuration of the part file
  • <$CLPRP:[PropertyName]> - any name of the cut-list property to read value from, e.g. is replaced with the value of cut-list custom property Thickness
  • <$PRP:[PropertyName]> - any name of the custom property of part to read value from, e.g. is replaced with the value of cut-list custom property PartNo

Placeholders will be resolved for each cut-list at runtime.

INDEX_FORMAT constant allows to specify the padding of the index for feature name if name is used. By default feature names resolved to the same value will have an index for second feature and so on, unless ALWAYS_ADD_INDEX constant is set to true. In this case first feature will have index as well.

For example the following setup (in case part PartNo equals to ABC) will resolve cut-list feature to ABC_001, ABC_002, ABC_003 etc.

Const NAME_TEMPLATE = "<$PRP:PartNo>_"
Const INDEX_FORMAT As String = "000"
Const ALWAYS_ADD_INDEX As Boolean = True

Watch video demonstration

Const NAME_TEMPLATE = "<_FileName_>_<$CLPRP:Description>_<$PRP:PartNo>"
Const INDEX_FORMAT As String = "0"
Const ALWAYS_ADD_INDEX As Boolean = False

Dim swApp As SldWorks.SldWorks

Sub main()

    On Error GoTo catch_
    Set swApp = Application.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    If Not swModel Is Nothing Then
        Dim vCutLists As Variant
        vCutLists = GetCutLists(swModel)
        Dim i As Integer
        For i = 0 To UBound(vCutLists)
            Dim swCutListFeat As SldWorks.Feature
            Set swCutListFeat = vCutLists(i)
            Dim featBaseName As String
            featBaseName = ComposeFeatureName(NAME_TEMPLATE, swModel, swCutListFeat)
            Dim featName As String
            featName = ResolveFeatureName(swModel, featBaseName)
            If featName <> "" Then
                If swCutListFeat.Name <> featName Then
                    swCutListFeat.Name = featName
                End If
                Debug.Print "Empty name for " & swCutListFeat.Name
            End If
        MsgBox "Please open the document"
    End If
    GoTo finally_

    swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk

End Sub

Function ResolveFeatureName(model As ModelDoc2, baseName As String) As String
    Dim featName As String
    If baseName <> "" Then
        Dim index As Integer
        If ALWAYS_ADD_INDEX Then
            index = 1
            featName = baseName + Format$(index, INDEX_FORMAT)
            index = 0
            featName = baseName
        End If
        While model.FeatureManager.IsNameUsed(swNameType_e.swFeatureName, featName)
            index = index + 1
            featName = baseName + Format$(index, INDEX_FORMAT)
        featName = ""
    End If
    ResolveFeatureName = featName
End Function

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

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

Function ComposeFeatureName(template As String, model As SldWorks.ModelDoc2, cutListFeat As SldWorks.Feature) As String

    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.IgnoreCase = True
    regEx.Pattern = "<[^>]*>"
    Dim regExMatches As Object
    Set regExMatches = regEx.Execute(template)
    Dim i As Integer
    Dim outFeatName As String
    outFeatName = template
    For i = regExMatches.Count - 1 To 0 Step -1
        Dim regExMatch As Object
        Set regExMatch = regExMatches.Item(i)
        Dim tokenName As String
        tokenName = Mid(regExMatch.Value, 2, Len(regExMatch.Value) - 2)
        outFeatName = Left(outFeatName, regExMatch.FirstIndex) & ResolveToken(tokenName, model, cutListFeat) & Right(outFeatName, Len(outFeatName) - (regExMatch.FirstIndex + regExMatch.Length))
    ComposeFeatureName = outFeatName
End Function

Function ResolveToken(token As String, model As SldWorks.ModelDoc2, cutListFeat As SldWorks.Feature) As String
    Const FILE_NAME_TOKEN As String = "_FileName_"
    Const CONF_NAME_TOKEN As String = "_ConfName_"
    Const PRP_TOKEN As String = "$PRP:"
    Const CUT_LIST_PRP_TOKEN As String = "$CLPRP:"
    Select Case LCase(token)
        Case LCase(FILE_NAME_TOKEN)
            ResolveToken = GetFileNameWithoutExtension(model.GetPathName)
        Case LCase(CONF_NAME_TOKEN)
            ResolveToken = model.ConfigurationManager.ActiveConfiguration.Name
        Case Else
            Dim prpName As String
            If Left(token, Len(PRP_TOKEN)) = PRP_TOKEN Then
                prpName = Right(token, Len(token) - Len(PRP_TOKEN))
                ResolveToken = GetModelPropertyValue(model, model.ConfigurationManager.ActiveConfiguration.Name, prpName)
            ElseIf Left(token, Len(CUT_LIST_PRP_TOKEN)) = CUT_LIST_PRP_TOKEN Then
                prpName = Right(token, Len(token) - Len(CUT_LIST_PRP_TOKEN))
                ResolveToken = GetPropertyValue(cutListFeat.CustomPropertyManager, prpName)
                Err.Raise vbError, "", "Unrecognized token: " & token
            End If
    End Select
End Function

Function GetModelPropertyValue(model As SldWorks.ModelDoc2, confName As String, prpName As String) As String
    Dim prpVal As String
    Dim swCustPrpMgr As SldWorks.CustomPropertyManager
    Set swCustPrpMgr = model.Extension.CustomPropertyManager(confName)
    prpVal = GetPropertyValue(swCustPrpMgr, prpName)
    If prpVal = "" Then
        Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
        prpVal = GetPropertyValue(swCustPrpMgr, prpName)
    End If
    GetModelPropertyValue = prpVal
End Function

Function GetPropertyValue(custPrpMgr As SldWorks.CustomPropertyManager, prpName As String) As String
    Dim resVal As String
    custPrpMgr.Get2 prpName, "", resVal
    GetPropertyValue = resVal
End Function

Function GetFileNameWithoutExtension(path As String) As String
    GetFileNameWithoutExtension = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1)
End Function

Product of Xarial Product of Xarial