Dissolving Multiple Sub-Assemblies 1

[chriswaura]

thread559-241981

I came across a thread today and found the suggested answer needed a bit of tweaking. User "handleman" delivered the goods and I am extremely happy I found it. I use Solidworks and and Altium designer. Every time we wanted to performa fit check on the circuits with our assemblies, it would produce the .stp files from Altium with sub assemblies full of sub assemblies of parts.

I found that the code worked, but would never fully dissolve a sub assembly, leaving it at one level. I changed the "If UBound(swComp.GetChildren) > 0 Then" to "-1" and it took it all out for me.

Hope this is useful to you as it was for me!

Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swComp As SldWorks.Component2
Dim myCompCollection As New Collection
Dim Info As String
Dim i As Long

Sub main()

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
If swDoc.GetType <> swDocASSEMBLY Then
    MsgBox "This macro only works in assemblies."
    Exit Sub
End If
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager
For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
    If swSelMgr.GetSelectedObjectType3(i, -1) = swSelCOMPONENTS Then
        Set swComp = swSelMgr.GetSelectedObject6(i, -1)
        If UBound(swComp.GetChildren) > -1 Then
            myCompCollection.Add swComp
        End If
    End If
Next i

swDoc.ClearSelection2 True
Info = ""
For i = 1 To myCompCollection.Count
    Set swComp = myCompCollection(i)
    swComp.Select4 False, Nothing, False
    Info = Info & "Successfully Dissolved " & swComp.Name2 & ": " & swAssy.DissolveSubAssembly & vbCrLf
Next i
    
Set myCompCollection = Nothing
If Info = "" Then Info = "No subassemblies were selected"
MsgBox "Subassembly dissolve results: " & vbCrLf & vbCrLf & Info
End Sub