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