CATIA二次开发：根装配下克隆生成独立Product而非组件问题

原代码的问题在于，它是在当前打开的Product文档内部创建子Product组件，这类组件属于嵌入对象，无法单独在新窗口打开。要实现可独立打开的克隆Product，需要直接创建新的ProductDocument，而非作为现有Product的子组件。

关键修改说明 #

• 创建独立Product文档：用CATIA.Documents.Add("Product")替代原代码中rootProd.Products.AddNewProduct()的方式，生成独立的Product文档
• 调整克隆目标：将递归克隆的目标从现有Product的子组件，改为新创建的独立Product的根节点
• 新增文档保存逻辑（可选）：确保新生成的Product文档被保存，避免关闭CATIA后丢失

修改后的完整代码 #

Option Explicit
Dim ProductCounter As Integer

Sub CreateStandaloneProductClone()
    Dim CATIA As Object
    Set CATIA = GetObject(, "CATIA.Application")

    If CATIA.Documents.Count = 0 Then
        MsgBox "无打开的文档。", vbExclamation
        Exit Sub
    End If

    Dim activeDoc As Document
    Set activeDoc = CATIA.ActiveDocument

    If TypeName(activeDoc) <> "ProductDocument" Then
        MsgBox "当前激活文档必须是ProductDocument（装配体）。", vbExclamation
        Exit Sub
    End If

    Dim sel As Selection
    Set sel = activeDoc.Selection
    If sel.Count <> 1 Or TypeName(sel.Item(1).Value) <> "Product" Then
        MsgBox "请选择且仅选择一个根产品节点进行克隆。", vbExclamation
        Exit Sub
    End If

    Dim rootSelectedProd As Product
    Set rootSelectedProd = sel.Item(1).Value

    ' 创建独立的Product文档，而非现有Product的子组件
    ProductCounter = 1
    Dim newProdDoc As ProductDocument
    Dim newRootProd As Product
    Set newProdDoc = CATIA.Documents.Add("Product")
    Set newRootProd = newProdDoc.Product
    
    ' 设置新Product的名称和编号
    Dim newProdName As String
    newProdName = "000product" & ProductCounter & "B"
    newRootProd.Name = newProdName
    newRootProd.PartNumber = newProdName

    ' 递归克隆结构到新的独立Product
    CopyStructureRecursive rootSelectedProd, newRootProd, CATIA.ActiveDocument.Selection, newProdName

    ' 可选：自动保存新文档（需替换为你的保存路径）
    ' newProdDoc.SaveAs "C:\Your\Save\Path\" & newProdName & ".CATProduct"

    MsgBox "已创建独立可打开的Product克隆：'" & newRootProd.Name & "'", vbInformation
End Sub

Sub CopyStructureRecursive(ByVal sourceProd As Product, ByVal targetProd As Product, ByRef sel As Selection, ByVal newProdName As String)
    Dim i As Integer
    Dim child As Product
    Dim partDoc As Document

    For i = 1 To sourceProd.Products.Count
        Set child = sourceProd.Products.Item(i)

        ' 防止无限递归
        If child.Name <> newProdName Then
            On Error Resume Next
            Set partDoc = child.ReferenceProduct.Parent
            On Error GoTo 0

            If child.Products.Count > 0 Then
                ' 处理子装配：在目标Product下创建新子Product
                ProductCounter = ProductCounter + 1
                Dim subProdName As String
                subProdName = "000product" & ProductCounter & "B"
                Dim newSubProd As Product
                Set newSubProd = targetProd.Products.AddNewProduct(subProdName)
                newSubProd.Name = subProdName
                newSubProd.PartNumber = subProdName

                CopyStructureRecursive child, newSubProd, sel, newProdName
            ElseIf Not partDoc Is Nothing And TypeName(partDoc) = "PartDocument" Then
                ' 处理零件：复制粘贴到目标Product
                sel.Clear
                sel.Add child
                sel.Copy
                sel.Clear
                sel.Add targetProd.Products
                sel.Paste
            End If
        End If
    Next i
End Sub

使用说明 #

1. 在CATIA中打开目标装配文档
2. 选中需要克隆的根Product节点
3. 运行CreateStandaloneProductClone宏
4. 新生成的Product会自动在新窗口打开，可独立编辑和保存

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