Rename All Features Sequentially

Features renamed sequentially

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