SW一键删除自定义属性

机械人三部曲：（SW一键删除自定义属性、批量自定义属性、批量更换工程图模板）
第一部：一键删除自定义属性
SW-工具-宏-新建-保存-删除里面的所有文字！-完整复制以下代码-调试-编译-运行-选择文件夹（切记备份）-完成

Option Explicit ’ 模块第一行

’ 核心逻辑
Sub BatchDeleteSWProps_YourLogic()
Dim swApp As Object ’ 仅用Object类型
Dim folderPath As String
Dim shellObj As Object ’ 弹窗选文件夹

' 1. 连接SW
Set swApp = CreateObject("SldWorks.Application")
swApp.Visible = True
If swApp Is Nothing Then
    MsgBox "SolidWorks未启动！", vbCritical
    Exit Sub
End If

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

' 3. 递归处理根文件夹及所有子文件夹
Call ProcessAllSubFolders(swApp, folderPath)

MsgBox "所有零件属性删除完成！", vbInformation
Set swApp = Nothing

End Sub

’ 递归处理文件夹
Private Sub ProcessAllSubFolders(swApp As Object, folderPath As String)
Dim fso As Object
Dim fileObj As Object
Dim subFolderObj As Object
Dim fileName As String
Dim fullPath As String
Dim swModel As Object
Dim propName As Variant

' 创建文件系统对象，用于遍历子文件夹
Set fso = CreateObject("Scripting.FileSystemObject")

' ========== 处理当前文件夹的零件 ==========
fileName = Dir(folderPath & "\*.sldprt")
Do While fileName <> ""
    ' 清空旧文件，重建干净环境
    swApp.CloseAllDocuments True
    DoEvents
    
    ' 拼接完整路径
    fullPath = folderPath & "\" & fileName
    
    ' 关键
    swApp.OpenDoc fullPath, 1
    DoEvents ' 等待SW打开并激活文件
    
    ' 核心
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        fileName = Dir
        GoTo NextFile
    End If
    
    ' 删除逻辑
    For Each propName In swModel.GetCustomInfoNames
        swModel.DeleteCustomInfo propName
    Next
    
    ' 保存+关闭+释放对象
    swModel.Save
    swApp.CloseDoc fullPath
    Set swModel = Nothing

NextFile:
fileName = Dir
Loop

' ========== 递归处理当前文件夹下的所有子文件夹 ==========
For Each subFolderObj In fso.GetFolder(folderPath).SubFolders
    Call ProcessAllSubFolders(swApp, subFolderObj.Path)
Next

Set fso = Nothing

End Sub