Hi,

I need to select Sub assembly (Not Top level) by its Custom Property.

I have Codes to select component by Custom property, Is there any way to select sub Assembly?

Option Explicit
    Dim swApp                      As Object
    Dim swModel                    As Object
    Dim swConf                      As Object
    Dim swRootComp                  As Object
Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim str As String
    ' Constant enumerators
    Const swDocPART = 1
    Const swDocASSEMBLY = 2
    Const swDocDRAWING = 3
    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        ' If no model currently loaded, then exit
        End
    End If
    ' Determine the document type
    ' If the document is not a drawing, then send a message to the user
    If (swModel.GetType <> swDocASSEMBLY) Then
        MsgBox "This Feature only for ASSEMBLY !", vbCritical, "Avantek Tools"
        End
     Else
     Call TRAVCOMP
     Debug.Print "ok"
    End If
    
End Sub
Sub TraverseComponent(swComp As Object, nLevel As Long)
    Dim vChildComp                  As Variant
    Dim swChildComp                As Object
    Dim swCompConfig                As Object
    Dim sPadStr                    As String
    Dim i                          As Long
    Dim retval, retval1                      As String
    Dim bRet                        As Boolean
    
For i = 0 To nLevel - 1
        sPadStr = sPadStr + "  "
    Next i
    vChildComp = swComp.GetChildren
    For i = 0 To UBound(vChildComp)
        Set swChildComp = vChildComp(i)
        TraverseComponent swChildComp, nLevel + 1
        
        Set swModel = swChildComp.GetModelDoc
         
        If Not swModel Is Nothing Then
            retval1 = swModel.CustomInfo2("", "Description")
              If InStr((retval1), "StripLayout") > 0 Then
                bRet = swChildComp.Select(True) 'SELECTS COMPONENT
            End If
        End If
    Next i
End Sub
 Sub TRAVCOMP()
    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    Set swConf = swModel.GetActiveConfiguration
    Set swRootComp = swConf.GetRootComponent
    Debug.Print "File = " & swModel.GetPathName
    Dim swModel2 As SldWorks.ModelDoc2
    Set swApp = Application.SldWorks
    Set swModel2 = swApp.ActiveDoc
    swModel2.ClearSelection2 True
    TraverseComponent swRootComp, 1
    Dim obj As Object
        
    swModel.Extension.RunCommand swCommands_HideShowComponents, Empty
   
swModel2.ClearSelection2 True
End Sub

Thanks