SolidWorks宏边界框计算类型不兼容问题排查求助

问题根源分析 #

出现XDim/YDim/ZDim类型不兼容错误，核心原因如下：

• GetBox返回无效值：组件处于轻量级状态、未解析或加载失败时，swComp.GetBox(False, False)会返回Empty而非有效数组，直接访问索引会触发类型不兼容错误。
• 未校验组件模型加载状态：swComp.GetModelDoc2可能返回Nothing（如轻量级零件），后续属性访问操作会引发连锁错误，间接干扰维度计算逻辑。
• 重复调用组件获取API：循环中每次调用swAssembly.GetComponents(False)(i)会降低性能，且可能获取到不一致的组件集合。
• XML标签格式错误：原代码存在标签名含空格（如<Part Number>）、引用未定义变量（如Name）等问题，会导致XML生成失败。

修复方案 #

1. 校验GetBox返回值：计算维度前，判断vBox是否为有效数组且包含6个元素。
2. 复用组件数组：使用提前获取的components数组遍历组件，避免重复调用API。
3. 处理未加载组件：判断swPart是否为Nothing，为空则跳过该组件并打印调试信息。
4. 修正XML标签：调整无效标签名，替换未定义变量，补充缺失的闭合标签，确保XML结构合法。
5. 完善变量声明：为未声明的变量添加明确类型，避免Variant类型引发的隐性错误。

修复后的完整代码 #

Sub AddCustomProperties()
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swAssembly As SldWorks.AssemblyDoc
    Dim swPart As SldWorks.PartDoc
    Dim swComp As SldWorks.Component2
    Dim swCustPropMgr As SldWorks.CustomPropertyManager
    Dim swFeatMgr As SldWorks.FeatureManager
    Dim swFeat As SldWorks.Feature
    
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    
    Dim xmlCode As String
    Dim filePath As String
    Dim fso As Object
    Dim ts As Object
    Dim asmName As String
    Dim CustomerVal As String
    Dim ProjectVal As String
    Dim components As Variant
    Dim partsCount As Integer
    Dim i As Integer
    Dim partNum As String
    Dim qty As Integer
    Dim Color As String
    Dim Material As String
    Dim finish As String
    Dim Process As String
    Dim vBox As Variant
    Dim XDim As Double
    Dim YDim As Double
    Dim ZDim As Double
    
    If Not swModel Is Nothing Then
        If swModel.GetType = swDocumentTypes_e.swDocASSEMBLY Then
            Set swAssembly = swModel
            
            Set swCustPropMgr = swAssembly.Extension.CustomPropertyManager("")
            asmName = swModel.GetTitle
            asmName = Left(asmName, Len(asmName) - 7) ' 移除.sldasm后缀
            Debug.Print "assembly name: " & asmName
            
            CustomerVal = swCustPropMgr.Get("Customer")
            ProjectVal = swCustPropMgr.Get("Project")
            
            components = swAssembly.GetComponents(False)
            
            If Not IsEmpty(components) Then
                partsCount = UBound(components) - LBound(components) + 1
            Else
                partsCount = 0
            End If
            
            Debug.Print "count:" & partsCount
            ' 修正XML标签，替换未定义变量
            xmlCode = "<Document>" & vbCrLf & _
                      "    <IdentifiantSW>" & asmName & "</IdentifiantSW>" & vbCrLf & _
                      "    <Configuration>" & vbCrLf & _
                      "        <Metadata>" & vbCrLf & _
                      "            <Customer>" & CustomerVal & "</Customer>" & vbCrLf & _
                      "            <Project>" & ProjectVal & "</Project>" & vbCrLf & _
                      "        </Metadata>" & vbCrLf & _
                      "    </Configuration>" & vbCrLf & _
                      "    <BOM>" & vbCrLf
            
            For i = LBound(components) To UBound(components)
                Set swComp = components(i)
                Debug.Print "component:" & swComp.Name
                
                If Not swComp Is Nothing Then
                    Set swPart = swComp.GetModelDoc2
                    
                    ' 检查零件是否加载成功
                    If Not swPart Is Nothing Then
                        Set swCustPropMgr = swPart.Extension.CustomPropertyManager("")
                        
                        partNum = swComp.Name
                        partNum = Left(partNum, Len(partNum) - 2) ' 移除后缀（如@1）
                        
                        qty = 1
                        Color = swCustPropMgr.Get("Color")
                        Material = swCustPropMgr.Get("Material")
                        finish = swCustPropMgr.Get("Finish")
                        Process = swCustPropMgr.Get("Process")
                        
                        vBox = swComp.GetBox(False, False)
                        
                        ' 校验边界盒是否为有效数组
                        If IsArray(vBox) And UBound(vBox) = 5 Then
                            XDim = vBox(3) - vBox(0)
                            YDim = vBox(4) - vBox(1)
                            ZDim = vBox(5) - vBox(2)
                            
                            ' 修正XML标签格式，补充闭合标签
                            xmlCode = xmlCode & "        <ListComponents>" & vbCrLf & _
                                      "            <Component>" & vbCrLf & _
                                      "                <PartNumber>" & partNum & "</PartNumber>" & vbCrLf & _
                                      "                <Description></Description>" & vbCrLf & _
                                      "                <Quantity>" & qty & "</Quantity>" & vbCrLf & _
                                      "                <Material>" & Material & "</Material>" & vbCrLf & _
                                      "                <Color>" & Color & "</Color>" & vbCrLf & _
                                      "                <Finish>" & finish & "</Finish>" & vbCrLf & _
                                      "                <Process>" & Process & "</Process>" & vbCrLf & _
                                      "                <Dimensions>" & vbCrLf & _
                                      "                    <X>" & XDim & "</X>" & vbCrLf & _
                                      "                    <Y>" & YDim & "</Y>" & vbCrLf & _
                                      "                    <Z>" & ZDim & "</Z>" & vbCrLf & _
                                      "                </Dimensions>" & vbCrLf & _
                                      "            </Component>" & vbCrLf & _
                                      "        </ListComponents>" & vbCrLf
                        Else
                            Debug.Print "组件" & swComp.Name & "边界盒获取失败"
                        End If
                    Else
                        Debug.Print "组件" & swComp.Name & "未加载，无法获取属性"
                    End If
                Else
                    MsgBox "Le composant n'a pas été trouvé dans l'assemblage"
                End If
            Next i
            
            xmlCode = xmlCode & "    </BOM>" & vbCrLf & _
                      "</Document>"
            
            MsgBox ("Generated the XML file successfully")
            
            swModel.Save
            
            filePath = "C:\Property.xml"
            
            Set fso = CreateObject("Scripting.FileSystemObject")
            Set ts = fso.CreateTextFile(filePath, True)
            ts.Write xmlCode
            ts.Close
        Else
            MsgBox "请打开SolidWorks装配体文件。"
        End If
    Else
        MsgBox "请打开SolidWorks文件。"
    End If
    
    ' 释放对象
    Set swCustPropMgr = Nothing
    Set swPart = Nothing
    Set swComp = Nothing
    Set swAssembly = Nothing
    Set swModel = Nothing
    Set swApp = Nothing
End Sub

关键修复点说明 #

• 边界盒有效性校验：通过IsArray(vBox) And UBound(vBox) = 5确保数组有效，避免类型错误。
• 组件数组复用：直接遍历提前获取的components数组，提升性能并保证集合一致性。
• 轻量级组件处理：判断swPart状态，跳过未加载组件，避免后续错误。
• XML标签修正：调整标签名格式，替换未定义变量，补充缺失的闭合标签，确保XML合法。

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