SOLIDWORKS宏问题：无法读取参考零件/装配体自定义属性

需求是编写宏实现：

• 打开工程图时读取其自定义属性QDS_revision
• 读取参考零件/装配体的自定义属性QDS_No
• 将工程图保存到同目录下的PDF文件夹，文件名格式为QDS_No+QDS_revision

当前代码能实现功能1和3，但读取参考模型的QDS_No时出现运行时错误91（对象变量或With块变量未设置），swCustPrpMgr = Nothing，现有代码如下：

Dim swApp As Object

Sub main()
Dim swApp           As SldWorks.SldWorks
Dim swModel         As SldWorks.ModelDoc2
Dim swDraw          As SldWorks.DrawingDoc
Dim swPart          As SldWorks.PartDoc

Dim swExportPDFData As SldWorks.ExportPdfData
Dim status          As Boolean
Dim errors          As Long, warnings As Long
Dim swCustPrpMgr    As SldWorks.CustomPropertyManager

Dim FullPath        As String
Dim Folder          As String
Dim NewFullPath     As String
Dim QDS_rev         As String
Dim QDS             As String


Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDraw = swModel

        ' 读取活动配置
        Dim swView                      As SldWorks.View
        Dim swBaseView                  As SldWorks.View
        Dim config                      As String
        
        Set swView = swDraw.GetFirstView
        Set swBaseView = swView.GetBaseView
        Set swView = swView.GetNextView
        config = swView.ReferencedConfiguration
        
        'Debug.Print "  " & config
        Set swCustPrpMgr = swModel.Extension.CustomPropertyManager(config)
        
        swCustPrpMgr.Get4 "QDS_No", False, "##", QDS   ' <=============Not either
        

Debug.Print QDS


'Save
status = swModel.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, errors, warnings)


If (swModel.GetType = swDocDRAWING) Then

    Set swCustPrpMgr = swModel.Extension.CustomPropertyManager("")
        swCustPrpMgr.Get4 "QDS_revision", False, "##", QDS_rev
        'swCustPrpMgr.Get4 "QDS_No", False, "##", QDS  ' <=============Not working either

    ' PathName of current model document
    FullPath = swModel.GetPathName

    ' get path name
    Folder = Left(FullPath, InStrRev(FullPath, "\"))
    Folder = Folder & "PDF" + "\"

    NewFullPath = Folder & QDS & QDS_rev & ".pdf"

    swModel.SaveAs3 NewFullPath, 0, 0

                        

End If

End Sub

问题分析 #

原代码核心错误是未正确获取参考模型的对象实例，错误地从工程图本身的配置中读取QDS_No属性，而该属性实际存在于工程图关联的零件/装配体中。此外，视图获取逻辑有误，GetFirstView返回的是图纸空白视图，直接调用GetNextView可能无法定位到正确的基础视图。

修正后的代码 #

Sub main()
    Dim swApp As SldWorks.SldWorks
    Dim swDraw As SldWorks.DrawingDoc
    Dim swRefModel As SldWorks.ModelDoc2 ' 参考模型对象
    Dim swView As SldWorks.View
    Dim swCustPrpMgr As SldWorks.CustomPropertyManager
    
    Dim FullPath As String
    Dim Folder As String
    Dim NewFullPath As String
    Dim QDS_rev As String
    Dim QDS_No As String
    Dim errors As Long, warnings As Long
    Dim folderExists As Boolean
    
    ' 初始化SOLIDWORKS应用
    Set swApp = Application.SldWorks
    Set swDraw = swApp.ActiveDoc
    
    ' 验证当前文档是工程图
    If swDraw.GetType <> swDocDRAWING Then
        MsgBox "请打开工程图文档后运行此宏！", vbExclamation
        Exit Sub
    End If
    
    ' 获取工程图的基础视图及参考模型
    Set swView = swDraw.GetFirstView
    Do While Not swView Is Nothing
        Set swRefModel = swView.ReferencedModelDoc
        If Not swRefModel Is Nothing Then
            Exit Do ' 找到第一个有参考模型的视图
        End If
        Set swView = swView.GetNextView
    Loop
    
    ' 检查是否成功获取参考模型
    If swRefModel Is Nothing Then
        MsgBox "工程图未关联任何零件/装配体模型！", vbExclamation
        Exit Sub
    End If
    
    ' 读取参考模型的QDS_No属性（使用默认配置）
    Set swCustPrpMgr = swRefModel.Extension.CustomPropertyManager("")
    swCustPrpMgr.Get4 "QDS_No", False, "##", QDS_No
    
    ' 读取工程图的QDS_revision属性
    Set swCustPrpMgr = swDraw.Extension.CustomPropertyManager("")
    swCustPrpMgr.Get4 "QDS_revision", False, "##", QDS_rev
    
    ' 验证属性是否读取成功
    If QDS_No = "" Or QDS_rev = "" Then
        MsgBox "QDS_No或QDS_revision属性未找到！", vbExclamation
        Exit Sub
    End If
    
    ' 处理PDF保存路径
    FullPath = swDraw.GetPathName
    Folder = Left(FullPath, InStrRev(FullPath, "\")) & "PDF\"
    
    ' 检查PDF文件夹是否存在，不存在则创建
    folderExists = Dir(Folder, vbDirectory) <> ""
    If Not folderExists Then
        MkDir Folder
    End If
    
    NewFullPath = Folder & QDS_No & QDS_rev & ".pdf"
    
    ' 保存为PDF
    swDraw.SaveAs3 NewFullPath, swSaveAsPDF, swSaveAsOptions_Silent, errors, warnings
    
    If errors = 0 Then
        MsgBox "PDF已成功保存至：" & NewFullPath, vbInformation
    Else
        MsgBox "保存PDF失败，错误代码：" & errors, vbCritical
    End If
    
End Sub

关键修正点 #

1. 正确获取参考模型：通过遍历视图找到关联的参考模型对象swRefModel，明确从参考模型中读取QDS_No属性。
2. 视图遍历逻辑：循环遍历所有视图，确保找到带有参考模型的视图，避免因视图顺序问题导致定位失败。
3. 文件夹存在性检查：新增文件夹创建逻辑，确保PDF保存路径有效。
4. 多步错误验证：增加文档类型、参考模型存在性、属性非空等验证，提升代码健壮性。

内容的提问来源于stack exchange，提问作者Galkata