This macro renames all the features in active model in the order, 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)
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Dim passedOrigin As Boolean
passedOrigin = False
If Not swModel Is Nothing Then
Dim featNamesTable As Object
Dim processedFeats As Collection
Set featNamesTable = CreateObject("Scripting.Dictionary")
Set processedFeats = New Collection
featNamesTable.CompareMode = vbTextCompare 'case insensitive
Dim swFeat As SldWorks.Feature
Set swFeat = swModel.FirstFeature
While Not swFeat Is Nothing
If passedOrigin Then
If Not Contains(processedFeats, swFeat) Then
processedFeats.Add swFeat
RenameFeature swFeat, featNamesTable
End If
Dim swSubFeat As SldWorks.Feature
Set swSubFeat = swFeat.GetFirstSubFeature
While Not swSubFeat Is Nothing
If Not Contains(processedFeats, swSubFeat) Then
processedFeats.Add swSubFeat
RenameFeature swSubFeat, featNamesTable
End If
Set swSubFeat = swSubFeat.GetNextSubFeature
Wend
End If
If swFeat.GetTypeName2() = "OriginProfileFeature" Then
passedOrigin = True
End If
Set swFeat = swFeat.GetNextFeature
Wend
Else
MsgBox "Please open model"
End If
End Sub
Sub RenameFeature(feat As SldWorks.Feature, featNamesTable As Object)
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(feat.Name)
If regExMatches.Count = 1 Then
If regExMatches(0).SubMatches.Count = 2 Then
Dim baseFeatName As String
baseFeatName = regExMatches(0).SubMatches(0)
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
feat.Name = baseFeatName & nextIndex
End If
End If
End Sub
Function Contains(coll As Collection, item As Object) As Boolean
Dim i As Integer
For i = 1 To coll.Count
If coll.item(i) Is item Then
Contains = True
Exit Function
End If
Next
Contains = False
End Function
