Macro to move suppressed mates into feature folder using SOLIDWORKS API
{ width=250 }
This VBA macro allows to move all suppressed mates to a nominated feature manager folder using SOLIDWORKS API. Macro will create folder if it doesn't exist or move to already existing one.
Macro will also move all unsuppressed mates of the folder if exist.
To configure the folder name, change the value of the FOLDER_NAME variable:
Const FOLDER_NAME As String = "<Folder Name>"
Const FOLDER_NAME As String = "SuppressedMates"
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Set swAssy = swApp.ActiveDoc
If Not swAssy Is Nothing Then
Dim vSuppMates As Variant
vSuppMates = GetAllSuppressedMates(swAssy)
If Not IsEmpty(vSuppMates) Then
Dim swFolderFeat As SldWorks.Feature
Set swFolderFeat = swAssy.FeatureByName(FOLDER_NAME)
If swFolderFeat Is Nothing Then
InsertMatesIntoNewFolder swAssy, vSuppMates, FOLDER_NAME
Else
Dim swFolder As SldWorks.FeatureFolder
Set swFolder = swFolderFeat.GetSpecificFeature2()
vSuppMates = ObjectArrayExcept(vSuppMates, swFolder.GetFeatures())
If Not IsEmpty(vSuppMates) Then
InsertMatesIntoExistingFolder swAssy, vSuppMates, swFolderFeat
End If
MoveUnsuppressedMatesFromFolder swAssy, swFolderFeat
End If
End If
Else
MsgBox "Please open assembly"
End If
End Sub
Sub InsertMatesIntoNewFolder(assm As SldWorks.AssemblyDoc, mates As Variant, folderName As String)
Dim swModel As SldWorks.ModelDoc2
Set swModel = assm
If swModel.Extension.MultiSelect2(mates, False, Nothing) = UBound(mates) + 1 Then
Set swFolderFeat = swModel.FeatureManager.InsertFeatureTreeFolder2(swFeatureTreeFolderType_e.swFeatureTreeFolder_Containing)
swFolderFeat.Name = folderName
Else
Err.Raise vbError, "", "Failed to select mates to add to new folder"
End If
End Sub
Sub InsertMatesIntoExistingFolder(assy As SldWorks.AssemblyDoc, mates As Variant, folderFeat As SldWorks.Feature)
Dim swLastFeatInFolder As SldWorks.Feature
While folderFeat.GetTypeName2() <> "FtrFolder" Or InStr(folderFeat.Name, "___EndTag___") = 0
Set swLastFeatInFolder = folderFeat
Set folderFeat = folderFeat.GetNextSubFeature
Wend
If swLastFeatInFolder.GetTypeName2() = "FtrFolder" Then
Err.Raise vbError, "", "Not supported. Folder is empty"
End If
Dim swModel As SldWorks.ModelDoc2
Set swModel = assy
Dim i As Integer
For i = 0 To UBound(mates)
Dim swMateFeat As SldWorks.Feature
Set swMateFeat = mates(i)
'swMoveLocation_e.swMoveToFolder option doesn't work, need to move after last mate in the folder
If False = swModel.Extension.ReorderFeature(swMateFeat.Name, swLastFeatInFolder.Name, swMoveLocation_e.swMoveAfter) Then
Err.Raise vbError, "", "Failed to move mate into the folder"
End If
Set swLastFeatInFolder = swMateFeat
Next
End Sub
Sub MoveUnsuppressedMatesFromFolder(assy As SldWorks.AssemblyDoc, folderFeat As SldWorks.Feature)
Dim swModel As SldWorks.ModelDoc2
Set swModel = assy
Dim swFolder As SldWorks.FeatureFolder
Set swFolder = folderFeat.GetSpecificFeature2
Dim vMates As Variant
vMates = swFolder.GetFeatures
If Not IsEmpty(vMates) Then
Dim i As Integer
For i = 0 To UBound(vMates)
Dim swMateFeat As SldWorks.Feature
Set swMateFeat = vMates(i)
If False = swMateFeat.IsSuppressed2(swInConfigurationOpts_e.swThisConfiguration, Empty)(0) Then
If False = swModel.Extension.ReorderFeature(swMateFeat.Name, "", swMoveLocation_e.swMoveToEnd) Then
Err.Raise vbError, "", "Failed to move mate out of the folder"
End If
End If
Next
End If
End Sub
Function GetAllSuppressedMates(assm As SldWorks.AssemblyDoc) As Variant
Dim swSuppMates() As SldWorks.Feature
Dim isInit As Boolean
isInit = False
Dim vMates As Variant
vMates = GetAllMates(assm)
If Not IsEmpty(vMates) Then
Dim i As Integer
For i = 0 To UBound(vMates)
Dim swMateFeat As SldWorks.Feature
Set swMateFeat = vMates(i)
If swMateFeat.IsSuppressed2(swInConfigurationOpts_e.swThisConfiguration, Empty)(0) Then
If isInit Then
ReDim Preserve swSuppMates(UBound(swSuppMates) + 1)
Else
ReDim swSuppMates(0)
isInit = True
End If
Set swSuppMates(UBound(swSuppMates)) = swMateFeat
End If
Next
End If
GetAllSuppressedMates = swSuppMates
End Function
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
GetAllMates = swMates
End Function
Function ObjectArrayExcept(mainArr As Variant, except As Variant) As Variant
Dim retVal() As Object
Dim isInit As Boolean
Dim i As Integer
For i = 0 To UBound(mainArr)
Dim item As Object
Set item = mainArr(i)
If Not ObjectArrayContains(except, item) Then
If isInit Then
ReDim Preserve retVal(UBound(retVal) + 1)
Else
ReDim retVal(0)
isInit = True
End If
Set retVal(UBound(retVal)) = item
End If
Next
If isInit Then
ObjectArrayExcept = retVal
Else
ObjectArrayExcept = Empty
End If
End Function
Function ObjectArrayContains(arr As Variant, item As Object) As Boolean
Dim i As Integer
For i = 0 To UBound(arr)
If arr(i) Is item Then
ObjectArrayContains = True
Exit Function
End If
Next
ObjectArrayContains = False
End Function