Remove all mates and fix components in SOLIDWORKS assembly
This VBA macro remove all mates from the active assembly and fixes all the top level components.
Macro allows to configure the actions to perform on the assembly by changing the values of the constants
Const FIX_COMPONENTS As Boolean = True 'True to fix components, False to keep components as is
Const REMOVE_MATES As Boolean = True 'True to remove mates, False to keep mates
Macro will fix all top level components, excluding all components which are instances of the pattern
This allows to significantly improve the performance of the assembly.
Const FIX_COMPONENTS As Boolean = True
Const REMOVE_MATES As Boolean = True
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
If REMOVE_MATES Then
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
Err.Raise vbError, "", "Failed to delete mates"
End If
Else
Err.Raise vbError, "", "Failed to select mates for deletion"
End If
End If
End If
If FIX_COMPONENTS Then
Dim vComps As Variant
vComps = GetAllComponents(swAssy)
If Not IsEmpty(vComps) Then
If swAssy.Extension.MultiSelect2(vComps, False, Nothing) = UBound(vComps) + 1 Then
swAssy.FixComponent
Else
Err.Raise vbError, "", "Failed to select components"
End If
End If
End If
Else
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
Do
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)
Else
ReDim swMates(0)
isInit = True
End If
Set swMates(UBound(swMates)) = swMateFeat
End If
Set swMateFeat = swMateFeat.GetNextSubFeature
Wend
If isInit Then
GetAllMates = swMates
Else
GetAllMates = Empty
End If
End Function
Function GetAllComponents(assm As SldWorks.AssemblyDoc) As Variant
Dim swComps() As SldWorks.Component2
Dim isInit As Boolean
isInit = False
Dim vComps As Variant
vComps = assm.GetComponents(True)
Dim i As Integer
For i = 0 To UBound(vComps)
Dim swComp As SldWorks.Component2
Set swComp = vComps(i)
If False = swComp.IsPatternInstance Then
If Not isInit Then
isInit = True
ReDim swComps(0)
Else
ReDim Preserve swComps(UBound(swComps) + 1)
End If
Set swComps(UBound(swComps)) = swComp
End If
Next
If isInit Then
GetAllComponents = swComps
Else
GetAllComponents = Empty
End If
End Function