Rename cut list features based on custom properties using SOLIDWORKS API
More 'Goodies'
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 custom properties and free text.
To configure the macro modify the values of NAME_TEMPLATE and PROPERTIES variables
- NAME_TEMPLATE can contain free text and 0-based placeholders which will be dynamically replaced by corresponding custom properties values
- Set the names of the properties to extract by assigning the Array of PROPERTIES variable in Init function
Const NAME_TEMPLATE = "FreeText_{0}_{1}_{2}_{3}" 'Each feature is renamed with FreeText_ followed by the value of the first custom property specified in PROPERTIES, then _ etc. Dim PROPERTIES As Variant Dim swApp As SldWorks.SldWorks Sub Init(Optional dummy As Variant = Empty) PROPERTIES = Array("Prp1", "Prp2", "Prp3", "Prp4") 'custom properties to extract. Value of Prp1 will replace {0}, Prp2 will replace {1} etc. End Sub
Watch video demonstration
Const NAME_TEMPLATE = "SM_{0}x{1}x{2}" Dim PROPERTIES As Variant Dim swApp As SldWorks.SldWorks Sub Init(Optional dummy As Variant = Empty) PROPERTIES = Array("Bounding Box Length", "Bounding Box Width", "Sheet Metal Thickness") End Sub Sub main() try_: On Error GoTo catch_ Init 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 vPrpVals As Variant vPrpVals = ReadProperties(swCutListFeat.CustomPropertyManager, PROPERTIES) Dim featName As String featName = FormatString(NAME_TEMPLATE, vPrpVals) If swCutListFeat.Name <> featName Then If featName <> "" Then Dim index As Integer index = 0 While swModel.FeatureManager.IsNameUsed(swNameType_e.swFeatureName, featName) index = index + 1 featName = FormatString(NAME_TEMPLATE, vPrpVals) + CStr(index) Wend swCutListFeat.Name = featName Else Debug.Print "Empty name for " & swCutListFeat.Name End If End If Next Else MsgBox "Please open the document" End If GoTo finally_ catch_: swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk finally_: End Sub Function ReadProperties(custPrpMgr As SldWorks.CustomPropertyManager, prpNames As Variant) As Variant Dim prpValues() As String ReDim prpValues(UBound(prpNames)) Dim i As Integer For i = 0 To UBound(prpNames) Dim resVal As String custPrpMgr.Get2 CStr(prpNames(i)), "", resVal prpValues(i) = resVal Next ReadProperties = prpValues 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 Loop If (Not swFeats) = -1 Then GetFeaturesByType = Empty Else 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 Else Dim i As Integer For i = 0 To UBound(featsArr) If swApp.IsSame(featsArr(i), thisFeat) = swObjectEquality.swObjectSame Then Exit Sub End If Next 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 Wend End Sub Function FormatString(inputStr As String, params As Variant) Dim resStr As String resStr = inputStr Dim i As Integer For i = 0 To UBound(params) resStr = Replace(resStr, "{" & i & "}", CStr(params(i))) Next FormatString = resStr End Function