Find features in the tree by type and/or name pattern using SOLIDWORKS API

Feature Manager Tree { width=250 }

This VBA macro allows to find features in the Feature Manager tree using SOLIDWORKS API.

Features can be found by specifying the type name and/or name pattern (with support of wildcards). Specify empty string for name or type name to ignore this filter.

Examples

Dim swFeat As SldWorks.Feature
Set swFeat = GetFirstFeature(swModel, "WeldMemberFeat") 'return first feature of WeldMemberFeat type (i.e. Structural Member)

Dim swFeat As SldWorks.Feature
Set swFeat = GetFirstFeature(swModel, "", "Sk*") 'return first feature which name starts with Sk

Dim vFeats As Variant
vFeats = GetAllFeatures(swModel, "WeldMemberFeat") 'return all features of WeldMemberFeat type (i.e. Structural Members)

Dim vFeats As Variant
vFeats = GetAllFeatures(swModel, "", "Sk*")'return all features whose names starts with Sk

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swModel As SldWorks.ModelDoc2
    
    Set swModel = swApp.ActiveDoc
    
    Dim swFirstWeldFeat As SldWorks.Feature
    Set swFirstWeldFeat = GetFirstFeature(swModel, "WeldMemberFeat")
    
    Dim swFirstSkFeat As SldWorks.Feature
    Set swFirstSkFeat = GetFirstFeature(swModel, "", "Sk*")
    
    Dim swAllWeldFeats As Variant
    swAllWeldFeats = GetAllFeatures(swModel, "WeldMemberFeat")
    
    Dim swAllSkFeats As Variant
    swAllSkFeats = GetAllFeatures(swModel, "", "Sk*")
    
End Sub

Function GetFirstFeature(model As SldWorks.ModelDoc2, Optional typeName As String = "", Optional namePattern As String = "") As SldWorks.Feature
    
    Dim vFeats As Variant
    vFeats = GetFeatures(model, typeName, True, namePattern)
    
    If Not IsEmpty(vFeats) Then
        Set GetFirstFeature = vFeats(0)
    Else
        Set GetFirstFeature = Nothing
    End If
    
End Function

Function GetAllFeatures(model As SldWorks.ModelDoc2, Optional typeName As String = "", Optional namePattern As String = "") As Variant
    GetAllFeatures = GetFeatures(model, typeName, False, namePattern)
End Function

Function GetFeatures(model As SldWorks.ModelDoc2, typeName As String, firstOnly As Boolean, Optional namePattern As String = "") As Variant
    
    Dim swTargFeatsColl As Collection
    Set swTargFeatsColl = New Collection
    
    Dim swProcFeatsColl As Collection
    Set swProcFeatsColl = New Collection
    
    Dim swFeat As SldWorks.Feature
    Set swFeat = model.FirstFeature()
    
    While Not swFeat Is Nothing
                
        If Not Contains(swProcFeatsColl, swFeat) Then
            swProcFeatsColl.Add swFeat
            
            If FilterFeature(swFeat, typeName, namePattern) Then
                swTargFeatsColl.Add swFeat
                If firstOnly Then
                    GetFeatures = CollectionToArray(swTargFeatsColl)
                    Exit Function
                End If
            End If
        End If
    
        CollectAllSubFeatures swFeat, swProcFeatsColl, swTargFeatsColl, typeName, namePattern, firstOnly
        
        If firstOnly And swTargFeatsColl.Count() >= 1 Then
            GetFeatures = CollectionToArray(swTargFeatsColl)
            Exit Function
        End If
        
        Set swFeat = swFeat.GetNextFeature
        
    Wend
    
    GetFeatures = CollectionToArray(swTargFeatsColl)
    
End Function

Function FilterFeature(feat As SldWorks.Feature, typeName As String, namePattern As String) As Boolean
    
    If typeName <> "" Then
        If LCase(feat.GetTypeName2()) <> LCase(typeName) Then
            FilterFeature = False
            Exit Function
        End If
    End If
    
    If namePattern <> "" Then
        If Not feat.Name Like namePattern Then
            FilterFeature = False
            Exit Function
        End If
    End If
    
    FilterFeature = True
    
End Function

Sub CollectAllSubFeatures(swFeat As SldWorks.Feature, procFeatsColl As Collection, targFeatsColl As Collection, typeName As String, namePattern As String, firstOnly As Boolean)
    
    Dim swSubFeat As SldWorks.Feature
    Set swSubFeat = swFeat.GetFirstSubFeature
        
    While Not swSubFeat Is Nothing
        
        If Not Contains(procFeatsColl, swSubFeat) Then
            procFeatsColl.Add swSubFeat
            If FilterFeature(swSubFeat, typeName, namePattern) Then
                targFeatsColl.Add swSubFeat
                If firstOnly Then
                    Exit Sub
                End If
            End If
        End If
        
        CollectAllSubFeatures swSubFeat, procFeatsColl, targFeatsColl, typeName, namePattern, firstOnly
        Set swSubFeat = swSubFeat.GetNextSubFeature
        
    Wend
    
End Sub

Function CollectionToArray(coll As Collection) As Variant
    
    If coll.Count() > 0 Then
        
        Dim arr() As Object
        
        ReDim arr(coll.Count() - 1)
        Dim i As Integer
        
        For i = 1 To coll.Count
            Set arr(i - 1) = coll(i)
        Next
        
        CollectionToArray = arr
        
    Else
        CollectionToArray = Empty
    End If
    
End Function

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

Examples​

Examples