A Product structure in CATIA can be inconveniently complex. A programmer often needs the knowledge of Product and Part relations which are not necessarily provided by CATIA’s infrastructure. Thus this example shows how to obtain the structure of a Product by utilizing recursive methods.

Core Functions

Class – C_DocStructureObject

Create a new class in your VBA-Project, call it C_DocStructureObject and copy & paste the following code


Public Product As Product
Public Name As String
Public PartNumber As String
Public DocType As String
Public Reference As Reference
Public RefPath As String
Public SubProductsCount As Integer
Public SubProductsN As String      'N = Name
Public SubProductsPN As String     'PN = PartNumber
Public layer As Integer
Public FileName As String
Public FilePath As String
Public IsComponent As Boolean

'' see EXAMPLE
'Public NomCla As String

Module – M_DocStructure

Now you create a new module called M_DocStructure and paste these lines (click on show source)


' ====================================================================
' ==  PUBLIC VARIABLES                                              ==
' == may be used throughout the code (after M_DocStructure call)    ==
' == können im Code (nach Aufruf von M_DocStructure call) beliebig  ==
' == benutzt werden.                                                ==
' ====================================================================
Public MainProductDoc As ProductDocument      ' root Product        ==
Public pProducts As Collection                ' pProducts           ==
  Public fProduct As C_DocStructureObject     '                     ==
Public pDocuments As Collection               ' pDocuments          ==
  Public fDocument As Document                '                     ==
' ====================================================================
'----------------------------
' MsgBox-Text
'=========================================================
Private Const MsgStr_NoDocs_EN = "No documents found. Macro will now end."
Private Const MsgStr_NoDocs_DE = "Keine Dokumente gefunden. Makro wird beendet."

'----------------------------
' CreateDocStructureObject:
' - creates a classobject and fills it with infos _
'   about the current product
' - erstellt ein Objekt der Klasse und füllt es mit _
'   Infos zum aktuellen Product
'=========================================================
Public Sub CreateDocStructureObject(iProduct As Product)
    Dim i As Integer
    ' create a new classobject
    ' neue Instanz der Klasse erzeugen
    Dim pProduct As C_DocStructureObject
      Set pProduct = New C_DocStructureObject
   On Error Resume Next
    With pProduct

        ' #########################################
        '
        ' ..add your code here..
        ' ..füge hier deinen code ein..
        '
        ' EXAMPLE:
        ' - add/uncomment this line in >C_DocStructureObject< -
        ' Public NomCla As String
        '
        ' - add/uncomment this line >here< -
        ' .NomCla = iProduct.Nomenclature
        ' #########################################

        ' get the product itself
        ' das Product selbst aufnehmen
        Set .Product = iProduct
        ' Name / PartNumber
        .Name = iProduct.Name
        .PartNumber = iProduct.PartNumber
        ' Type, either "Product" or "Part"
        .DocType = ProductType(iProduct)
        ' checks if product is a component
        ' überprüft, ob das Product eine Component ist
        .IsComponent = IsComp2(iProduct)
        ' Product/Part Reference
        '#####################
            Dim TS_Backup As Collection
            Set TS_Backup = New Collection
            With CATIA.ActiveDocument.Selection
                For i = 1 To .Count
                    TS_Backup.Add .Item(i)
                Next i
            End With
        '#####################
        Dim TS As Selection: Set TS = MainProductDoc.Selection: TS.Clear
          TS.Add iProduct
          Set .Reference = TS.Item(1).Reference
          .RefPath = TS.Item(1).Reference.DisplayName
        '#####################
            With CATIA.ActiveDocument.Selection
                .Clear
                For i = 1 To TS_Backup.Count
                    .Add TS_Backup.Item(i).Value
                Next i
            End With
        '#####################
        ' sub-products count, Names, PartNumbers
        .SubProductsCount = iProduct.Products.Count
        Dim SPN As String: SPN = vbNullString
        Dim SPPN As String: SPPN = vbNullString
        For i = 1 To iProduct.Products.Count
            If SPN = vbNullString Then SPN = iProduct.Products.Item(i).Name _
            Else SPN = SPN & "^" & iProduct.Products.Item(i).Name
        Next i
        .SubProductsN = SPN
        For i = 1 To iProduct.Products.Count
            If SPPN = vbNullString Then SPPN = iProduct.Products.Item(i).PartNumber _
            Else SPPN = SPPN & "^" & iProduct.Products.Item(i).PartNumber
        Next i
        .SubProductsPN = SPPN
        ' layer
        .layer = layer
        ' FileName and FilePath
        If iProduct Is MainProductDoc.Product Then
            .FileName = MainProductDoc.Name
            .FilePath = MainProductDoc.Path
        Else
            ' you cannot get the filename from iProduct directly _
            ' but you can look for iProduct in pDocuments using _
            ' the Partnumber. fDocument then holds Filename and -path
            For Each fDocument In pDocuments
                If fDocument.Product.PartNumber = iProduct.PartNumber Then
                    .FileName = fDocument.Name
                    .FilePath = fDocument.Path
                    Exit For
                End If
            Next fDocument
        End If
    End With
    ' add current pProduct to collection
    ' aktuelles pProduct zu Collection hinzufügen
   If Err.Number = 0 Then
    pProducts.Add pProduct
   End If
End Sub

'#########################################################
'#########################################################
'#########################################################
'#########################################################
'----------------------------
' CATMain() - Start Function -
'=========================================================
Public Sub CATMain()
    Dim i As Integer
    ' get active document
    ' aktives Dokument definieren
   On Error Resume Next
    Set MainProductDoc = CATIA.ActiveDocument
   If Err.Number <> 0 Then
       ' in case no document was found
       ' falls keine Dokument gefunden wurde
       Call MsgBox(MsgStr_NoDocs_EN & Chr(10) & _
                   MsgStr_NoDocs_DE, vbInformation)
       ' exit macro
       End
   End If
   On Error GoTo 0
    ' init variables
    Dim PreSelections As Collection
    Set PreSelections = New Collection
    Set pProducts = New Collection
    Set pDocuments = New Collection
    ' collection with documents (only Parts and Products)
    ' Collection mit documents (nur Parts und Products)
    With CATIA.Documents
        For i = 1 To .Count
            If TypeName(.Item(i)) = "ProductDocument" _
            Or TypeName(.Item(i)) = "PartDocument" Then _
                pDocuments.Add .Item(i)
        Next i
    End With
    ' save currently selected objects
    ' speichern der ausgewählten Objekte
    For i = 1 To MainProductDoc.Selection.Count
        PreSelections.Add MainProductDoc.Selection.Item(i).Value
    Next i
    ' add active document, because function DocStructure wont
    ' Actives Dokument aufnehmen weil es von der Funktion _
    ' DocStructure nicht aufgenommen wird
    Call CreateDocStructureObject(MainProductDoc.Product)
    ' "layer" is the document-level the script is currently on
    ' "layer" bezeichnet die Dokumentenebene, auf der sich das _
    ' Programm gerade befindet
    Dim s_layer As Integer: s_layer = 1
    ' "mark" marks the current position on a layer
    ' "mark" dient zum Verfolgen der aktuellen Position auf dem _
    ' jeweiligen "layer"
    Dim s_mark() As Integer: ReDim s_mark(s_layer): s_mark(s_layer) = 1
    ' call recursive function to get the product structure
    ' rekursive Produkterkennung aufrufen
    Call DocStructure(MainProductDoc.Product.Products, s_mark, s_layer)
    ' restore selected objects
    ' Wiederherstellen der Objekte
    MainProductDoc.Selection.Clear
    For i = 1 To PreSelections.Count
        MainProductDoc.Selection.Add PreSelections.Item(i)
    Next i
' DEBUG HERE
' ==========
'For i = 1 To pProducts.Count
'    Debug.Print pProducts.Item(i).Product.Name
'Next i
End Sub

'----------------------------
' Doc_Structure:
' - recursive function to get the structure _
'   of any assembly
' - rekursive Funktion zum Aufnehmen einer _
'   beliebigen Baugruppe
'=========================================================
Private Function DocStructure(iProducts As Products, ByRef mark() As Integer, layer As Integer)
    ' grow "mark" if needed
    ' "mark" bei Bedarf erweitern
    If UBound(mark) < layer Then
        ' grow "mark", if we go one level down
        ' "mark" erweitern, falls es eine Ebene tiefer ins Produkt geht
        ReDim Preserve mark(layer)
        ' set "mark" to 1 in the new "layer"
        ' "mark" im neu erstellten "layer" auf 1 setzten
        mark(layer) = 1
    End If
    ' as long as there are products that haven't been checked
    ' solange noch Products da sind, die noch nicht untersucht wurden
    If mark(layer) <= iProducts.Count Then
        ' create a class object that holds information about the _
        ' current product/part
        ' erstellt ein Klassenobjekt mit Informationen über das _
        ' momentane Product/Part
        Call CreateDocStructureObject(iProducts.Item(mark(layer)))
        ' if the current product has subproducts go one level _
        ' deeper and call this function
        ' falls im ersten item der Products noch Unter-Products _
        ' sind, dann gehe eine Ebene tiefer und rufe diese _
        ' Funktion auf
        If iProducts.Item(mark(layer)).Products.Count > 0 Then
            Call DocStructure(iProducts.Item(mark(layer)).Products, mark, layer + 1)
        ' or else go one item further and call this function
        ' ansonsten gehe ein Item weiter und rufe diese _
        ' Function auf
        Else
            ' if there are items left in the product
            ' falls im Product noch Items vorhanden sind
            If mark(layer) < iProducts.Count Then
                mark(layer) = mark(layer) + 1
                Call DocStructure(iProducts, mark, layer)
            ' or else we go one level up again
            ' ansonsten gehen wir wieder eine Ebene zurück
            Else
                If layer >= 2 Then
                    mark(layer - 1) = mark(layer - 1) + 1
                    ' reset "mark" on the lower levels
                    ' "mark" auf den tieferen Ebenen wieder zurücksetzten
                    ReDim Preserve mark(layer - 1)
                    Call DocStructure(iProducts.Parent.Parent, mark, layer - 1)
                Else
                   Exit Function
                End If
            End If
        End If
    ' in case the last subproduct/subpart is reached
    ' falls wir beim letzten Unter-Product/Unter-Part angekommen sind
    Else
        If layer >= 2 Then
            mark(layer - 1) = mark(layer - 1) + 1
            ' reset "mark" on the lower levels
            ' "mark" auf den tieferen Ebenen wieder zurücksetzten
            ReDim Preserve mark(layer - 1)
            Call DocStructure(iProducts.Parent.Parent, mark, layer - 1)
        End If
    End If
End Function

'----------------------------
' ProductType:
' - gets the product-type
' - ermittelt den Produkt-Typen
'=========================================================
Public Function ProductType(iProducts As Products) As String
    Dim tryPart As Part
    ProductType = "Product"
   On Error Resume Next
    Set tryPart = iProducts.Parent.ReferenceProduct.Parent.Part
   If Err.Number = 0 Then ProductType = "Part"
   On Error GoTo 0
End Function

'----------------------------
' IsComp:
' - checks if product is a component
' - überprüft, ob das Produkt eine Komponente ist
'=========================================================
Public Function IsComp(iProduct As Product) As Boolean
   On Error Resume Next
    Dim P1 As Product, P2 As Product
    IsComp = True
    Set P1 = iProduct.ReferenceProduct
   ' falls das Objekt keine Product ist, ist es auch
   ' keine Component
   If Err.Number <> 0 Then
       IsComp = False
       Exit Function
   End If
    For Each fDocument In pDocuments
        Set P2 = fDocument.Product
      ''If P1 Is P2 Then
        If P1.PartNumber = P2.PartNumber And _
           P1.Name = P2.Name Then
            IsComp = False
            Exit For
        End If
    Next
End Function

'----------------------------
' IsComp2 (by Little Cthulhu):
' - checks if product is a component
' - überprüft, ob das Produkt eine Komponente ist
'=========================================================
Public Function IsComp2(prdProductToCheck As Product) As Boolean
    ' check that product is not a root (otherwise it is definitely NOT component)
    If (TypeOf prdProductToCheck.Parent Is Application) Then
        ' it is a root product and NOT a component
        IsComp2 = False
    Else
        ' check refernce product (where it is located)
      ''If (prdProductToCheck.ReferenceProduct Is prdProductToCheck.ReferenceProduct.Parent.Product) Then
        If (prdProductToCheck.ReferenceProduct.PartNumber = prdProductToCheck.ReferenceProduct.Parent.Product.PartNumber) And _
           (prdProductToCheck.ReferenceProduct.Name = prdProductToCheck.ReferenceProduct.Parent.Product.Name) Then
            IsComp2 = False
        Else
            IsComp2 = True
        End If
    End If
End Function

'----------------------------
' FindParentProductDocument:
' - gets the parent product document (components are skipped)
' - findet das übergeordnete Produktdokument (das keine Komp. ist)
'=========================================================
Public Function FindParentProductDocument(iProduct As Product) As ProductDocument
    Dim LoopCount As Integer: LoopCount = 0
    Do
        ' nach 100 Objekten wird die Suche abgebrochen
        If LoopCount > 100 Then Exit Do
        Set iProduct = iProduct.Parent.Parent
        LoopCount = LoopCount + 1
    Loop While M_DocStructure.IsComp2(iProduct)

    If LoopCount <= 100 Then
        For Each fDocument In pDocuments
            If fDocument.Product.PartNumber = iProduct.ReferenceProduct.PartNumber And _
               fDocument.Product.Name = iProduct.ReferenceProduct.Name Then
                Set FindParentProductDocument = fDocument
                Exit For
            End If
        Next fDocument
    End If
End Function

'----------------------------
' RemItemFromCollection:
' - removes an item from a collection
' - entfernt ein Objekt aus einer Collection
'=========================================================
Public Function RemItemFromCollection(iCollection As Collection, iPartNumber As String) As Boolean
    Dim j As Integer
    For j = 1 To pProducts.Count
      If iCollection.Item(j).PartNumber = iPartNumber Then
          iCollection.Remove j
          Exit For
      End If
    Next j
    RemItemFromCollection = True
End Function

Release Objects

Always good practice to release object variables when the macro ends. You can

Call ObjectsRelease

from a QueryClose – function for example.

Sub ObjectsRelease()
 On Error Resume Next
  ' public variables

  ...

  ' M_Doc_Structure
  Set MainProductDoc = Nothing
  Set pProducts = Nothing
  Set fProduct = Nothing
  Set pDocuments = Nothing
  Set fDocument = Nothing
End Sub

Usage/Examples

You can

Call M_DocStructure.CATMain

from your CATMain() for example. After you call this line in your code you will have two public Collections (pProducts and pDocuments) which hold all Parts and Products in your ActiveDocument.


'macro:     <macro-name>
'version:   <macro-version>
'code:      MSVBA
'purpose:   ...
'author:    ...
'date:      ...
'copyright: ...
'-----------------------------------------------------------------------------
'changes:   ...
'-----------------------------------------------------------------------------
'Option Explicit                           'optional

...

'----------------------------
' CATMain
'=========================================================
Sub CATMain()

  ...

  ' Document Structure aufrufen
  Call M_DocStructure.CATMain

  ...

End Sub

Module – M_PartProductRename

See Renaming a selected Part or Product (and most other Objects).

This method (compared to Little Cthulhu’s Script) relies on a recursive function to obtain the product structure. The disadvantage of recursive methods is the speed. The difference will be neglect-able on small and “normal” sized assemblies, very large assemblies with many hundred parts and products will significantly slow down the speed of the function.



' EN
'Public Const MsgStr_newName As String = "Enter a new Name:"
'Public Const MsgStr_newPartNumber As String = "Enter a new Partnumber:"
'Public Const SelStr As String = "Select any Object:"
' DE
Public Const MsgStr_newName As String = "Einen neuen Namen eingeben:"
Public Const MsgStr_newPartNumber As String = "Eine neue Teilenummer eingeben:"
Public Const SelStr As String = "Ein beliebiges Objekt auswählen:"

Sub CATMain()
    ' der String, der angehangen wird
    Dim strZusatz As String
    strZusatz = "_whatever"

'#######################################
    Dim i As Integer
    ' recursive product structure
    Call M_DocStructure.CATMain

    Dim selection1 As Selection, selElement As Object
      Set selection1 = MainProductDoc.Selection ': Selection1.Clear
''    Dim IOT(0): IOT(0) = "AnyObject" '"Product"
''    Dim strReturn As String
''    ' Benutzer soll ein Part oder ein Produkt auswählen
''    strReturn = Selection1.SelectElement2(IOT, SelStr, False)
''    If strReturn = "Normal" Then Set selElement = Selection1.Item(1).Value Else End

    If selection1.Count = 0 Then
        Call MsgBox("Es wurden keine Elemente ausgewählt.", vbExclamation)
        End
    End If

    For i = 1 To selection1.Count
        Set selElement = selection1.Item(i).Value
        Select Case TypeName(selElement)
            ' -- FALLS DIE AUSWAHL EIN PRODUCT IST --
            Case Is = "Product"
                Dim curProduct As Product
                    Set curProduct = selElement
                Dim curProductName As String
                    curProductName = curProduct.Name

                ' falls das ausgewählte Produkt das Root-Produkt ist
                ' Root-Produkt hat nur eine PartNumber, keinen Namen
                If curProduct.ReferenceProduct Is MainProductDoc.Product Then
                    With MainProductDoc.Product
                        Call M_DocStructure.RemItemFromCollection(pProducts, .PartNumber)
                        .PartNumber = .PartNumber & strZusatz
                        Call M_DocStructure.CreateDocStructureObject(MainProductDoc.Product)
                    End With
                Else
                    ' finde Parent Product
                    Dim ParentProduct As Product
                    For Each fProduct In pProducts
                        If fProduct.Product Is curProduct Then
                            Set ParentProduct = fProduct.Product.Parent.Parent
                            Exit For
                        End If
                    Next

                    ' überprüfen, ob ParentProduct eine Komponente ist
                    If M_DocStructure.IsComp2(ParentProduct) Then
                        Dim ParentProductDocument As ProductDocument
                            Set ParentProductDocument = M_DocStructure.FindParentProductDocument(curProduct)
                        Dim CSProduct As Product
                            Set CSProduct = ParentProductDocument.GetItem(ParentProduct.PartNumber).Products.Item(curProductName)
                        CSProduct.Name = CSProduct.Name & strZusatz
                    ' falls ParentProduct ein normales Product ist
                    Else
                        ' Dateiname ParentProduct
                        Dim ParentProductFileName As String
                        Dim ParentProductPartNumber As String
                        For Each fProduct In pProducts
                            If fProduct.Product Is ParentProduct Then
                                ParentProductFileName = fProduct.FileName
                                ParentProductPartNumber = fProduct.PartNumber
                                Exit For
                            End If
                        Next fProduct
                   'On Error Resume Next
                        With CATIA.Documents.Item(ParentProductFileName).Product.Products.Item(curProduct.Name)
                            Call M_DocStructure.RemItemFromCollection(pProducts, .PartNumber)
                            ' Exemplarname
                            .Name = .Name & strZusatz
                            ' Teilenummer
                           '.PartNumber = .PartNumber & strZusatz
                            Call M_DocStructure.CreateDocStructureObject(CATIA.Documents.Item(ParentProductFileName).Product.Products.Item(.Name))
                        End With
                   'On Error GoTo 0
                    End If
                End If
            ' -- FALLS DIE AUSWAHL EIN PART IST --
            Case Is = "Part"
                Dim curPart As Part
                    Set curPart = selElement
              'On Error Resume Next
                For Each pProduct In pProducts
                    If curPart.Name = pProduct.PartNumber And Not pProduct.IsComponent Then
                        ' Part hat nur eine PartNumber
                        pProduct.Product.PartNumber = pProduct.Product.PartNumber & strZusatz
                        Exit For
                    End If
                Next pProduct
              'On Error GoTo 0
            ' -- FALLS DIE AUSWAHL WEDER EIN PRODUCT NOCH EIN PART IST --
            Case Else
               On Error Resume Next
                selElement.Name = selElement.Name & strZusatz
               On Error GoTo 0
        End Select
    Next i
End Sub

You can also download the (ready-to-go) sample library VBA-PartProductRename.catvba.

Module – M_CountParts



'macro:     <macro-name>
'version:   <macro-version>
'code:      MSVBA
'purpose:   ...
'author:    ...
'date:      ...
'copyright: ...
'-----------------------------------------------------------------------------
'changes:   ...
'-----------------------------------------------------------------------------
'Option Explicit                           'optional

'----------------------------
' CATMain
'=========================================================
Sub CATMain()
    ' Document Structure aufrufen
    Call M_DocStructure.CATMain

    Dim part_counter As Integer
    part_counter = 0
    Dim PartsFound As Collection
    Set PartsFound = New Collection
    Dim PN As Variant
    Dim PartFound As Boolean
    Dim eachpart_PN() As String
    Dim eachpart_count() As Integer

    For i = 1 To pProducts.Count
        Set fProduct = pProducts.Item(i)
        If fProduct.DocType = "Part" Then
            PartFound = False
            For Each PN In PartsFound
                If PN = fProduct.PartNumber Then
                    PartFound = True
                    For j = LBound(eachpart_PN) To UBound(eachpart_PN)
                        If eachpart_PN(j) = fProduct.PartNumber Then _
                            eachpart_count(j) = eachpart_count(j) + 1
                    Next
                End If
            Next
            If PartFound = False Then
                part_counter = part_counter + 1
                PartsFound.Add fProduct.PartNumber

                ReDim Preserve eachpart_PN(part_counter)
                eachpart_PN(part_counter) = fProduct.PartNumber

                ReDim Preserve eachpart_count(part_counter)
                eachpart_count(part_counter) = 1
            End If
        End If
    Next

    ' Ausgabe
    Dim str As String
    For i = 1 To UBound(eachpart_PN)
        str = str & eachpart_PN(i) & " (" & CStr(eachpart_count(i)) & ")" & " ; "
    Next

    MsgBox "Im aktuellen Product befindet/befinden sich " & part_counter & " Part(s):" & Chr(10) & str

End Sub

Function – GetRootProduct

GetRootProduct is a sample function which makes use of these Collections to find the Root-Product of two Parts (part1 and part2). The Root-Product is needed for example to make constraints between part1 and part2 via VBA, because unlike the manual way (mouse clicks), in VBA CATIA doesn’t automatically put the constraints into the correct Product.. but more about (more complex) constraints between parts and products later.
(click on show source)


'----------------------------
' GetRootProduct:
' - finds the root-product of two parts
' - Findet das gemeinsame RootProduct von zwei Parts
'=========================================================
Public Function GetRootProduct(part1 As Part, part2 As Part) As Product
    Dim i As Integer
    Dim part1_found As Boolean, part2_found As Boolean
        part1_found = False:    part2_found = False
    Dim part1_Ref As String, part2_Ref As String
    Dim part1_ArrRef() As String
    Dim part2_ArrRef() As String

    ' Document Structure
    Call M_DocStructure.CATMain
    For Each fProduct In pProducts
        If fProduct.PartNumber = part1.Name Then
            part1_found = True
            part1_Ref = fProduct.RefPath
        End If
        If fProduct.PartNumber = part2.Name Then
            part2_found = True
            part2_Ref = fProduct.RefPath
        End If

        ' wenn beide Parts gefunden wurden, kann die Schleife verlassen werden
        If part1_found And part2_found Then Exit For
    Next fProduct

    part1_ArrRef = Split(part1_Ref, "/")
    part2_ArrRef = Split(part2_Ref, "/")

    Dim partArr_MinLength As Integer, partArr_Start As Integer

    ' kürzeres Array suchen und dessen Länge speichern
    If UBound(part1_ArrRef) < UBound(part2_ArrRef) Then
        partArr_MinLength = UBound(part1_ArrRef)
        partArr_Start = LBound(part1_ArrRef)
    Else
        partArr_MinLength = UBound(part2_ArrRef)
        partArr_Start = LBound(part2_ArrRef)
    End If

    Dim CRefPath As String

    ' prüfen bis wohin die Referenzen zu part1 und part2 gleich sind
    For i = partArr_Start To partArr_MinLength
        If part1_ArrRef(i) = part2_ArrRef(i) Then
            CRefPath = CRefPath & part1_ArrRef(i) & "/"
        Else
            Exit For
        End If
    Next i

    ' anhand des ermittelten Referenz Pfads kann nun das gemeinsame Rootproduct von part1
    ' und part2 zurückgegeben werden
    For Each fProduct In pProducts
        If fProduct.RefPath = CRefPath Then
            Set GetRootProduct = fProduct.Product
            Exit For
        End If
    Next fProduct
    ' das Root Product selbst wird (noch) nicht gefunden, daher wird es hier manuell gesetzt
    ' falls es ausgewählt wurde
    If GetRootProduct Is Nothing Then Set GetRootProduct = MainProductDoc.Product
End Function