Skip to main content

SOLIDWORKS macro renames all features in model sequentially

Features renamed sequentially

This macro renames all the features in active model in the sequential order using SOLIDWORKS API, preserving the base names .

Only indices are renamed and the base name is preserved. For example Sketch21 will be renamed to Sketch1 for the first appearance of the sketch feature.

Notes

  • Only features with number at the end will be renamed (e.g. Front Plane will not be renamed to Front Plane1 and My1Feature will not be renamed)
  • Case is ignored (case insensitive search)
  • Only modelling features are renamed (the ones created after the Origin feature)
  • In the assembly documents, only assembly feature are renamed (components are ignored)
  • If components are selected in the assembly, features of those components will be renamed

Watch video demonstration

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2

Sub main()

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

try_:

On Error GoTo catch_

If Not swModel Is Nothing Then

swModel.FeatureManager.EnableFeatureTree = False
swModel.FeatureManager.EnableFeatureTreeWindow = False

Dim vComps As Variant

vComps = GetSelectedComponents(swModel.SelectionManager)

If Not IsEmpty(vComps) Then

Dim i As Integer

For i = 0 To UBound(vComps)

Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
ProcessFeatureTree swComp.FirstFeature, swComp

Next

Else
ProcessFeatureTree swModel.FirstFeature, swModel
End If

Else
Err.Raise vbError, "", "Please open model"
End If

GoTo finally_

catch_:
swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally_:

If Not swModel Is Nothing Then
swModel.FeatureManager.EnableFeatureTree = True
swModel.FeatureManager.EnableFeatureTreeWindow = True
End If

End Sub

Sub ProcessFeatureTree(firstFeat As SldWorks.Feature, owner As Object)

Dim passedOrigin As Boolean
passedOrigin = False

Dim featNamesTable As Object
Dim processedFeats() As SldWorks.Feature

Set featNamesTable = CreateObject("Scripting.Dictionary")

featNamesTable.CompareMode = vbTextCompare 'case insensitive

Dim swFeat As SldWorks.Feature
Set swFeat = firstFeat

While Not swFeat Is Nothing

If passedOrigin Then

If Not Contains(processedFeats, swFeat) Then

If (Not processedFeats) = -1 Then
ReDim processedFeats(0)
Else
ReDim Preserve processedFeats(UBound(processedFeats) + 1)
End If

Set processedFeats(UBound(processedFeats)) = swFeat

RenameFeature swFeat, featNamesTable, owner
End If

Dim swSubFeat As SldWorks.Feature
Set swSubFeat = swFeat.GetFirstSubFeature

While Not swSubFeat Is Nothing

If Not Contains(processedFeats, swSubFeat) Then
If (Not processedFeats) = -1 Then
ReDim processedFeats(0)
Else
ReDim Preserve processedFeats(UBound(processedFeats) + 1)
End If

Set processedFeats(UBound(processedFeats)) = swSubFeat
RenameFeature swSubFeat, featNamesTable, owner
End If

Set swSubFeat = swSubFeat.GetNextSubFeature

Wend

End If

If swFeat.GetTypeName2() = "OriginProfileFeature" Then
passedOrigin = True
End If

Set swFeat = swFeat.GetNextFeature
Wend

End Sub

Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object, owner As Object)

If feat.GetTypeName2() <> "Reference" Then

Dim baseFeatName As String

If TryGetBaseName(feat.name, baseFeatName) Then

Dim nextIndex As Integer

If featNamesTable.Exists(baseFeatName) Then
nextIndex = featNamesTable.item(baseFeatName) + 1
featNamesTable.item(baseFeatName) = nextIndex
Else
nextIndex = 1
featNamesTable.Add baseFeatName, nextIndex
End If

Dim newName As String
newName = baseFeatName & nextIndex

If LCase(feat.name) <> LCase(newName) Then

ResolveFeatureNameConflict owner, newName

feat.name = newName

End If

End If

End If

End Sub

Function TryGetBaseName(name As String, ByRef baseName As String)

TryGetBaseName = False
baseName = ""

Dim regEx As Object
Set regEx = CreateObject("VBScript.RegExp")

regEx.Global = True
regEx.IgnoreCase = True
regEx.Pattern = "(.+?)(\d+)$"

Dim regExMatches As Object
Set regExMatches = regEx.Execute(name)

If regExMatches.Count = 1 Then

If regExMatches(0).SubMatches.Count = 2 Then

baseName = regExMatches(0).SubMatches(0)
TryGetBaseName = True

End If

End If

End Function

Sub ResolveFeatureNameConflict(owner As Object, name As String)

Const INDEX_OFFSET As Integer = 100
Dim index As Integer

Dim swFeatMgr As SldWorks.FeatureManager

Dim swFeat As SldWorks.Feature

If TypeOf owner Is SldWorks.Component2 Then

Dim swComp As SldWorks.Component2
Set swComp = owner

Dim swRefModel As SldWorks.ModelDoc2
Set swRefModel = swComp.GetModelDoc2

If Not swRefModel Is Nothing Then
Set swFeatMgr = swRefModel.FeatureManager
Set swFeat = swComp.FeatureByName(name)
Else
Err.Raise vbError, "", "Component model is not loaded"
End If

ElseIf TypeOf owner Is SldWorks.ModelDoc2 Then

Dim swModel As SldWorks.ModelDoc2
Set swModel = owner
Set swFeatMgr = swModel.FeatureManager
Set swFeat = swModel.FeatureByName(name)

Else
Err.Raise vbError, "", "Not supported owner"
End If

If Not swFeat Is Nothing Then

Dim baseName As String

If TryGetBaseName(name, baseName) Then

Dim newName As String
newName = baseName & (INDEX_OFFSET + index)

While False <> swFeatMgr.IsNameUsed(swNameType_e.swFeatureName, newName)
index = index + 1
newName = baseName & (INDEX_OFFSET + index)
Wend

swFeat.name = newName

Else
Exit Sub
End If

End If

End Sub

Function Contains(vArr As Variant, item As Object) As Boolean

Dim i As Integer

For i = 0 To UBound(vArr)
If vArr(i) Is item Then
Contains = True
Exit Function
End If
Next

Contains = False

End Function

Function GetSelectedComponents(selMgr As SldWorks.SelectionMgr) As Variant

Dim isInit As Boolean
isInit = False

Dim swComps() As SldWorks.Component2

Dim i As Integer

For i = 1 To selMgr.GetSelectedObjectCount2(-1)

Dim swComp As SldWorks.Component2

Set swComp = selMgr.GetSelectedObjectsComponent4(i, -1)

If Not swComp Is Nothing Then

If Not isInit Then
ReDim swComps(0)
Set swComps(0) = swComp
isInit = True
Else
If Not Contains(swComps, swComp) Then
ReDim Preserve swComps(UBound(swComps) + 1)
Set swComps(UBound(swComps)) = swComp
End If
End If

End If

Next

If isInit Then
GetSelectedComponents = swComps
Else
GetSelectedComponents = Empty
End If

End Function