VBA求救 toolbox组件压缩

2217190245 · 发表于 2024-7-1 10:11:54

经典图书

下面是代码能否请大神帮忙看看是哪里出现了问题,运行后也没有报错就是不将toolbox件压缩

Dim swApp As Object
Dim Part As Object

Sub Main()
' 获取当前SolidWorks应用程序对象
Set swApp = Application.SldWorks
' 获取当前打开的文档
Set Part = swApp.ActiveDoc

If Not Part Is Nothing Then
      If Part.GetType = 2 Then ' 检查当前文档是否是装配体
         ProcessAssembly Part
      Else
         MsgBox "当前打开的文档不是装配体。", vbExclamation, "操作失败"
      End If
Else
      MsgBox "未找到当前打开的文档。", vbExclamation, "操作失败"
End If
End Sub

Sub ProcessAssembly(swAssy As Object)
Dim vComponents As Variant
Dim swComp As Object
Dim i As Long
Dim successCount As Long

successCount = 0

' 获取装配体中的所有组件
vComponents = swAssy.GetComponents(False)

' 遍历所有组件
For i = 0 To UBound(vComponents)
      Set swComp = vComponents(i)

      ' 输出组件名称
      Debug.Print "处理组件: " & swComp.Name2

      ' 确保组件未被压缩且是Toolbox标准件
      If Not swComp.IsSuppressed And IsToolboxComponent(swComp) Then
         If SelectAndSuppressComponent(swComp) Then
            successCount = successCount + 1
            Debug.Print "成功压缩组件: " & swComp.Name2
         Else
            Debug.Print "无法压缩组件: " & swComp.Name2
         End If
      End If
Next i

' 显示运行成功消息框
MsgBox "Toolbox 标准件压缩操作成功完成。成功压缩了 " & successCount & " 个组件。", vbInformation, "操作成功"
End Sub

Function IsToolboxComponent(swComp As Object) As Boolean
Dim swModelDoc As Object
Dim swCustPropMgr As Object
Dim valOut As String
Dim resolvedValOut As String
Dim wasResolved As Boolean
Dim linkToProperty As Boolean

' 获取组件的模型文档
Set swModelDoc = swComp.GetModelDoc2

If Not swModelDoc Is Nothing Then
      ' 获取自定义属性管理器
      Set swCustPropMgr = swModelDoc.Extension.CustomPropertyManager("")

      ' 使用 Get6 方法获取 IsToolboxPart 属性值
      swCustPropMgr.Get6 "IsToolboxPart", False, valOut, resolvedValOut, wasResolved, linkToProperty

      ' 输出属性值
      Debug.Print "组件名称: " & swComp.Name2 & ", IsToolboxPart 值: " & valOut

      ' 如果属性值为 "Yes"，则是 Toolbox 标准件
      If valOut = "Yes" Then
         IsToolboxComponent = True
      End If
End If
End Function

Function SelectAndSuppressComponent(swComp As Object) As Boolean
Dim boolstatus As Boolean

' 选择组件
boolstatus = swComp.Select4(False, Nothing)

If boolstatus Then
      ' 压缩组件
      swComp.EditSuppress2
      ' 清除选择
      swApp.ActiveDoc.ClearSelection2 True
End If

SelectAndSuppressComponent = boolstatus
End Function