使用SOLIDWORKS API将被压制的约束移动到特征文件夹的宏
{ width=250 }
这个VBA宏允许使用SOLIDWORKS API将所有被压制的约束移动到指定的特征管理器文件夹中。如果文件夹不存在,宏将创建一个新的文件夹或者移动到已经存在的文件夹中。
如果文件夹中存在未被压制的约束,宏也会将它们移动到文件夹中。
要配置文件夹名称,请更改FOLDER_NAME变量的值:
Const FOLDER_NAME As String = "<文件夹名称>"
Const FOLDER_NAME As String = "被压制的约束"
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 "请打开装配体"
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, "", "选择要添加到新文件夹的约束失败"
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, "", "不支持。文件夹为空"
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选项不起作用,需要在文件夹中的最后一个约束之后移动
If False = swModel.Extension.ReorderFeature(swMateFeat.Name, swLastFeatInFolder.Name, swMoveLocation_e.swMoveAfter) Then
Err.Raise vbError, "", "将约束移动到文件夹失败"
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, "", "将约束移出文件夹失败"
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