How to skip identical parts with GetComponents

[Wasermelone]

Hello everyone,

I have written a macro that goes trough all components in the assembly and subassemblies and makes drawings from all the parts. However I have a problem that if the part is used more than once in a assembly (on the top level and/or in the subassembly) it makes a drawing for each instance of the part so there is as many drawings of the same part as there is instances of that part. Is there are way to skip identical instances? Maybe I'm missing something about GetComponents method?

Thank you

[JSculley]

Create a List or Array. After you process a component, add its path to the list. Before you process a component, check to see if its path is in the list, and skip it if it is.

[Stefan Sterk]

I start by making a list of unique components and then loop through it. as demonstrated by the code below

Code: Select all

Option Explicit

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swUniqueCompList() As SldWorks.Component2
    Dim swComp As SldWorks.Component2
    Dim vComp As Variant
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then End
    If swModel.GetType <> swDocASSEMBLY Then End
    
    swUniqueCompList = GetUniqueCompList(swModel)
    For Each vComp In swUniqueCompList
    
        Set swComp = vComp
        Debug.Print swComp.GetPathName
        
    Next vComp
    
End Sub

Function GetUniqueCompList(swModel As SldWorks.ModelDoc2) As SldWorks.Component2()
    Dim swUniqueCompList() As SldWorks.Component2
    Dim swConf As SldWorks.Configuration
    Dim swRootComp As SldWorks.Component2
    
    Set swConf = swModel.GetActiveConfiguration
    Set swRootComp = swConf.GetRootComponent3(True)
    ReDim swUniqueCompList(0)
    Set swUniqueCompList(0) = swRootComp
    TraverseComponent swRootComp, swUniqueCompList
    GetUniqueCompList = swUniqueCompList
    
End Function

Sub TraverseComponent(swComp As SldWorks.Component2, swUniqueCompList() As SldWorks.Component2)
    Dim vChildComp As Variant
    Dim swChildComp As SldWorks.Component2

    For Each vChildComp In swComp.GetChildren
        Set swChildComp = vChildComp
        If Not IsCompInList(swUniqueCompList, swChildComp) Then
            ReDim Preserve swUniqueCompList(UBound(swUniqueCompList) + 1)
            Set swUniqueCompList(UBound(swUniqueCompList)) = swChildComp
        End If
        TraverseComponent swChildComp, swUniqueCompList
    Next vChildComp

End Sub

Function IsCompInList(swCompArr() As SldWorks.Component2, swComp As SldWorks.Component2) As Boolean
    Dim vComp As Variant

    For Each vComp In swCompArr
        If StrComp(vComp.GetPathName, swComp.GetPathName, vbTextCompare) = 0 Then
            'If StrComp(vComp.ReferencedConfiguration, swComp.ReferencedConfiguration, vbTextCompare) = 0 Then
                IsCompInList = True
                Exit Function
            'End If
        End If
    Next vComp

End Function

[Wasermelone]

I start by making a list of unique components and then loop through it. as demonstrated by the code below

Code: Select all

Option Explicit

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swUniqueCompList() As SldWorks.Component2
    Dim swComp As SldWorks.Component2
    Dim vComp As Variant
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then End
    If swModel.GetType <> swDocASSEMBLY Then End
    
    swUniqueCompList = GetUniqueCompList(swModel)
    For Each vComp In swUniqueCompList
    
        Set swComp = vComp
        Debug.Print swComp.GetPathName
        
    Next vComp
    
End Sub

Function GetUniqueCompList(swModel As SldWorks.ModelDoc2) As SldWorks.Component2()
    Dim swUniqueCompList() As SldWorks.Component2
    Dim swConf As SldWorks.Configuration
    Dim swRootComp As SldWorks.Component2
    
    Set swConf = swModel.GetActiveConfiguration
    Set swRootComp = swConf.GetRootComponent3(True)
    ReDim swUniqueCompList(0)
    Set swUniqueCompList(0) = swRootComp
    TraverseComponent swRootComp, swUniqueCompList
    GetUniqueCompList = swUniqueCompList
    
End Function

Sub TraverseComponent(swComp As SldWorks.Component2, swUniqueCompList() As SldWorks.Component2)
    Dim vChildComp As Variant
    Dim swChildComp As SldWorks.Component2

    For Each vChildComp In swComp.GetChildren
        Set swChildComp = vChildComp
        If Not IsCompInList(swUniqueCompList, swChildComp) Then
            ReDim Preserve swUniqueCompList(UBound(swUniqueCompList) + 1)
            Set swUniqueCompList(UBound(swUniqueCompList)) = swChildComp
        End If
        TraverseComponent swChildComp, swUniqueCompList
    Next vChildComp

End Sub

Function IsCompInList(swCompArr() As SldWorks.Component2, swComp As SldWorks.Component2) As Boolean
    Dim vComp As Variant

    For Each vComp In swCompArr
        If StrComp(vComp.GetPathName, swComp.GetPathName, vbTextCompare) = 0 Then
            'If StrComp(vComp.ReferencedConfiguration, swComp.ReferencedConfiguration, vbTextCompare) = 0 Then
                IsCompInList = True
                Exit Function
            'End If
        End If
    Next vComp

End Function

Thank you, this worked flawlessly!