跳到主要内容

删除SOLIDWORKS装配体中的所有约束并固定组件

特征管理器树中的约束

这个VBA宏会从活动装配体中删除所有约束并固定所有顶层组件。

通过更改常量的值,宏允许配置在装配体上执行的操作

Const FIX_COMPONENTS As Boolean = True 'True表示固定组件,False表示保持组件不变
Const REMOVE_MATES As Boolean = True 'True表示删除约束,False表示保留约束

该宏将固定所有顶层组件,但不包括模式的实例组件

这样可以显著提高装配体的性能。

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, "仅支持装配体文档"
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, "", "删除约束失败"
End If
Else
Err.Raise vbError, "", "选择要删除的约束失败"
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, "", "选择组件失败"
End If
End If

End If

Else
Err.Raise vbError, "", "请打开装配体文档"
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