SW 宏 一键删除配置属性，2D的材料明细表数量不会出错，**切记备份**

SW 宏 一键删除配置属性，2D的材料明细表数量不会出错，切记备份
完整复制以下代码，操作步骤和一键删除自定义属性一样
Option Explicit

’ 主过程：入口函数，弹窗选文件夹后批量处理所有零件
Sub main_BatchDeleteAllConfigProps()
Dim rootFolderPath As String
Dim shellObj As Object

' 弹窗选择要处理的根文件夹
Set shellObj = CreateObject("Shell.Application")
Set shellObj = shellObj.BrowseForFolder(0, "请选择零件根文件夹（遍历所有子文件夹）", 16, 0)
If shellObj Is Nothing Then
    MsgBox "未选择文件夹，操作取消！", vbExclamation
    Exit Sub
End If
rootFolderPath = shellObj.Self.Path
Set shellObj = Nothing

' 调用递归子过程
Call ProcessAllFolders(rootFolderPath)

MsgBox "所有零件的所有配置属性已批量删除完成！", vbInformation

End Sub

’ 递归子过程：处理当前文件夹+所有子文件夹的零件
Private Sub ProcessAllFolders(folderPath As String)
Dim swApp As Object
Dim fso As Object
Dim fileObj As Object
Dim subFolderObj As Object
Dim fullPath As String
Dim Part As Object
Dim fileName As String

' ========== 稳定获取SW对象（全版本兼容） ==========
Set swApp = GetSWApp()
If swApp Is Nothing Then
    MsgBox "SolidWorks未启动！", vbCritical
    Exit Sub
End If
swApp.Visible = True

Set fso = CreateObject("Scripting.FileSystemObject")

' ========== 改用Dir遍历 ==========
fileName = Dir(folderPath & "\*.sldprt")
Do While fileName <> ""
    fullPath = folderPath & "\" & fileName
    
    ' 清空已打开文件
    swApp.CloseAllDocuments True
    DoEvents
    Set swApp = GetSWApp() ' 重新获取，避免对象丢失
    If swApp Is Nothing Then GoTo NextFile
    
    ' ========== 核心 ==========
    swApp.OpenDoc fullPath, 1 ' 1=零件类型
    DoEvents
    Set Part = swApp.ActiveDoc ' 核心代码
    If Part Is Nothing Then
        MsgBox "零件打开失败：" & fullPath, vbExclamation
        GoTo NextFile
    End If
    
    ' ========== 100% ==========
    Dim CurCFGname As Variant
    Dim CurCFGnameCount As Long
    Dim i As Long
    Dim CusPrOPMgr As Object
    Dim Vnamearr As Variant
    Dim Vnamearr2 As Variant
    Dim bRet As Boolean
    
    CurCFGname = Part.GetConfigurationNames ' 逻辑
    CurCFGnameCount = Part.GetConfigurationCount ' 逻辑
    
    For i = 0 To CurCFGnameCount - 1
        Set CusPrOPMgr = Part.Extension.CustomPropertyManager(CurCFGname(i)) ' 逻辑
        Vnamearr = CusPrOPMgr.GetNames ' 逻辑
        
        If Not IsEmpty(Vnamearr) Then
            For Each Vnamearr2 In Vnamearr
                bRet = Part.DeleteCustomInfo2(CurCFGname(i), Vnamearr2) ' 逻辑
            Next
        End If
    Next
    ' ========== 核心逻辑 ==========
    
    ' 保存+关闭（逻辑一致）
    Part.Save
    swApp.CloseDoc fullPath
    Set Part = Nothing

NextFile:
fileName = Dir
Loop

' ========== 递归处理子文件夹 ==========
For Each subFolderObj In fso.GetFolder(folderPath).SubFolders
    Call ProcessAllFolders(subFolderObj.Path)
Next

Set fso = Nothing
Set swApp = Nothing

End Sub

’ 辅助函数：稳定获取SW对象（全版本兼容）
Private Function GetSWApp() As Object
On Error Resume Next
’ 优先获取已运行的SW，失败则创建
Set GetSWApp = CreateObject(“SldWorks.Application”)
On Error GoTo 0
End Function