Get corresponding entities (faces, edges and vertices) in the derived part using SOLIDWORKS API

IPartDoc::InsertPart3 API allows to insert a derived part into another part. However the API to find the corresponding entity of the input part, similarly to components is not available.

This VBA macro demonstrates a performance efficient workaround for this limitation.

Running the macro

Open the source part (this is the part to be inserted into another part). This part must be saved on the disc
Select one or many entities (faces, edges, vertices). These can be selected in different bodies in case of the multi-body part
Run the macro. Macro will index inputs and stop the execution
Open or create new part where the source part needs to be inserted
Continue macro execution
As the result derived part is inserted and all the corresponding entities are selected

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    
    Dim swSrcModel As SldWorks.ModelDoc2
    
    Set swSrcModel = swApp.ActiveDoc
    
    If swSrcModel.GetType() <> swDocumentTypes_e.swDocPART Then
        Err.Raise vbError, "", "Only parts are supported"
    End If
    
    Dim trackDefId As Integer
    trackDefId = TrackSelectedEntities(swSrcModel)
    
    Stop
    
    Dim swTargModel As SldWorks.ModelDoc2
    Set swTargModel = swApp.ActiveDoc
    
    Dim swTargPart As SldWorks.PartDoc
    Set swTargPart = swTargModel
    
    Dim swDerPartFeat As SldWorks.Feature
    
    Set swDerPartFeat = swTargPart.InsertPart3(swSrcModel.GetPathName(), swInsertPartOptions_e.swInsertPartImportSolids, swSrcModel.ConfigurationManager.ActiveConfiguration.Name)
    
    Dim vTrackedEnts As Variant
    vTrackedEnts = GetTrackedEntitites(swTargModel, swDerPartFeat, trackDefId)
    
    If Not IsEmpty(vTrackedEnts) Then
        swTargModel.Extension.MultiSelect2 vTrackedEnts, False, Nothing
    Else
        Err.Raise vbError, "", "No tracked entities found"
    End If
    
End Sub

Function TrackSelectedEntities(model As SldWorks.ModelDoc2) As Integer
    
    Dim trackDefId As Integer
    
    trackDefId = swApp.RegisterTrackingDefinition("_DerivedPartTrack_")
    
    Dim i As Integer
    
    For i = 1 To model.SelectionManager.GetSelectedObjectCount2(-1)
            
        Select Case model.SelectionManager.GetSelectedObjectType3(i, -1)
            Case swSelectType_e.swSelFACES
                Dim swFace As SldWorks.Face2
                Set swFace = model.SelectionManager.GetSelectedObject6(i, -1)
                If swFace.SetTrackingID(trackDefId, i) <> swTrackingIDError_e.swTrackingIDError_NoError Then
                    Err.Raise vbError, "", "Failed to track face"
                End If
            Case swSelectType_e.swSelEDGES
                Dim swEdge As SldWorks.Edge
                Set swEdge = model.SelectionManager.GetSelectedObject6(i, -1)
                If swEdge.SetTrackingID(trackDefId, i) <> swTrackingIDError_e.swTrackingIDError_NoError Then
                    Err.Raise vbError, "", "Failed to track edge"
                End If
            Case swSelectType_e.swSelVERTICES
                Dim swVertex As SldWorks.Vertex
                Set swVertex = model.SelectionManager.GetSelectedObject6(i, -1)
                If swVertex.SetTrackingID(trackDefId, i) <> swTrackingIDError_e.swTrackingIDError_NoError Then
                    Err.Raise vbError, "", "Failed to track vertex"
                End If
            Case Else
                Err.Raise vbError, "", "Only faces, edges and vertices are supported"
        End Select
        
    Next
    
    TrackSelectedEntities = trackDefId
    
End Function

Function GetTrackedEntitites(model As SldWorks.ModelDoc2, derFeatPart As SldWorks.Feature, trackDefId As Integer) As Variant

    Dim isInit As Boolean
    isInit = False
    Dim swEnts() As SldWorks.Entity
    
    Dim searchTypes(2) As Integer
    searchTypes(0) = swTopoEntity_e.swTopoFace
    searchTypes(1) = swTopoEntity_e.swTopoEdge
    searchTypes(2) = swTopoEntity_e.swTopoVertex
    
    Dim vBodies As Variant
    vBodies = GetFeatureBodies(derFeatPart)
    
    Dim i As Integer
    
    For i = 0 To UBound(vBodies)
    
        Dim vTrackedEnts As Variant
        Dim swBody As SldWorks.Body2
        Set swBody = vBodies(i)
        
        vTrackedEnts = model.Extension.FindTrackedObjects(trackDefId, swBody, searchTypes, Empty)
        
        If Not IsEmpty(vTrackedEnts) Then
            If Not isInit Then
                isInit = True
                ReDim swEnts(UBound(vTrackedEnts))
            Else
                ReDim Preserve swEnts(UBound(swEnts) + UBound(vTrackedEnts) + 1)
            End If
            
            Dim j As Integer
            
            For j = 0 To UBound(vTrackedEnts)
                Dim swEnt As SldWorks.Entity
                Set swEnt = vTrackedEnts(j)
                Set swEnts(UBound(swEnts) - UBound(vTrackedEnts) + j) = swEnt
            Next
            
        End If
    
    Next

    If isInit Then
        GetTrackedEntitites = swEnts
    Else
        GetTrackedEntitites = Empty
    End If

End Function

Function GetFeatureBodies(feat As SldWorks.Feature) As Variant
    
    Dim isInit As Boolean
    isInit = False
    
    Dim swBodies() As SldWorks.Body2

    Dim i As Integer
    
    Dim vFaces As Variant
    
    vFaces = feat.GetFaces
    
    For i = 0 To UBound(vFaces)
                
        Dim swFace As SldWorks.Face2
    
        Set swFace = vFaces(i)
        
        Dim swBody As SldWorks.Body2
        
        Set swBody = swFace.GetBody
        
            If Not isInit Then
                ReDim swBodies(0)
                Set swBodies(0) = swBody
                isInit = True
            Else
                If Not Contains(swBodies, swBody) Then
                    ReDim Preserve swBodies(UBound(swBodies) + 1)
                    Set swBodies(UBound(swBodies)) = swBody
                End If
            End If
    
    Next

    If isInit Then
        GetFeatureBodies = swBodies
    Else
        GetFeatureBodies = Empty
    End If

End Function

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