Remove all mates and fix components in SOLIDWORKS assembly

Edit ArticleEdit Article
More 'Goodies'

Mates in the Feature Manager Tree
Mates in the Feature Manager Tree

This VBA macro remove all mates from the active assembly and fixes all the top level components.

This allows to significantly improve the performance of the assembly.

Dim swApp As SldWorks.SldWorks

Sub main()

    Set swApp = Application.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    If Not swModel Is Nothing Then
        If swModel.GetType() <> swDocumentTypes_e.swDocASSEMBLY Then
            Err.Raise vbError, "Only assembly document is supported"
        End If
        Dim swAssy As SldWorks.AssemblyDoc
        Set swAssy = swModel
        Dim vMates As Variant
        vMates = GetAllMates(swAssy)
        If Not IsEmpty(vMates) Then
            If swModel.Extension.MultiSelect2(vMates, False, Nothing) = UBound(vMates) + 1 Then
                If False <> swModel.Extension.DeleteSelection2(swDeleteSelectionOptions_e.swDelete_Absorbed) Then
                    Dim vComps As Variant
                    vComps = swAssy.GetComponents(True)
                    If swModel.Extension.MultiSelect2(vComps, False, Nothing) = UBound(vComps) + 1 Then
                        Err.Raise vbError, "", "Faield to select components"
                    End If
                    Err.Raise vbError, "", "Failed to delete mates"
                End If
                Err.Raise vbError, "", "Failed to select mates for deletion"
            End If
            Err.Raise vbError, "", "No mates in the assembly"
        End If
        Err.Raise vbError, "", "Please open assemby document"
    End If
End Sub

Function GetAllMates(assm As SldWorks.AssemblyDoc) As Variant
    Dim swMates() As SldWorks.Feature
    Dim isInit As Boolean
    isInit = False
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = assm
    Dim swMateGroupFeat As SldWorks.Feature
    Dim featIndex As Integer
    featIndex = 0
        Set swMateGroupFeat = swModel.FeatureByPositionReverse(featIndex)
        featIndex = featIndex + 1
    Loop While swMateGroupFeat.GetTypeName2() <> "MateGroup"
    Dim swMateFeat As SldWorks.Feature
    Set swMateFeat = swMateGroupFeat.GetFirstSubFeature
    While Not swMateFeat Is Nothing
        If TypeOf swMateFeat.GetSpecificFeature2() Is SldWorks.Mate2 Then
            If isInit Then
                ReDim Preserve swMates(UBound(swMates) + 1)
                ReDim swMates(0)
                isInit = True
            End If
            Set swMates(UBound(swMates)) = swMateFeat
        End If
        Set swMateFeat = swMateFeat.GetNextSubFeature
    GetAllMates = swMates
End Function

Product of Xarial Product of Xarial