Sub Main()

'Language = "VBSCRIPT"

Dim KomponenteNeu 'As Products
Dim KoerperName
Dim OpenKoerperName
Dim hybridBodies 'As Document
Dim Koerper  As Object
Dim QuellFenster 'As Window
Dim Letztekoerper
Dim UserSel 'As Selection


    Dim Activdocu 'As Document
    Set Activdocu = CATIA.ActiveDocument
    

    '---------------------------------------------------
    ' Neue Product
    '---------------------------------------------------
    Dim PosString As Long
    
    partname = CATIA.ActiveDocument.Name
    
    If Right(partname, 7) <> "CATPart" Then
        MsgBox (" Sie haben kein CATPART aktiv. Das Makro wird beendet.")
        End
    End If
    
    '------------------------------------------------------
    'Abfrage ob leere Bodies mitkopiert werden sollen

    Dim b_mitleere As Boolean
    Box = MsgBox("Sollen Parts für leere Bodies angelegt werden?", 4, "LeereBodies")

    If Box = 7 Then          'nein
        b_mitleere = False
    ElseIf Box = 6 Then      'ja
        b_mitleere = True
    End If
    '------------------------------------------------------
       
    Dim docu 'As Documents
    Set docu = CATIA.Documents
    
    Dim productDocu 'As Document
    Set productDocu = docu.Add("Product")
    
    Dim ProductNeu  'As Product
    Set ProductNeu = productDocu.Product
    
    PosString = InStr(1, partname, ".CATPart")
    ProductNeu.PartNumber = Mid(partname, 1, PosString - 1)
    '------------------------------------------------------
    
    FensterNebeneinander
    
    Set QuellFenster = CATIA.Windows.Item(1)
    QuellFenster.Activate
    
    Dim partBodies 'As Bodies
    'Set Activdocu = CATIA.ActiveDocument
    Set partBodies = Activdocu.Part.Bodies
    
    Dim koerperAnzahl
    koerperAnzahl = partBodies.Count
    
    'Dim UserSel 'As Object
    Dim PartNeu 'As Product
    Dim workPart 'As PartDocument
    For i = 1 To koerperAnzahl
        
        Set Koerper = partBodies.Item(i)
        KoerperName = Koerper.Name
        
        If Right(KoerperName, 1) = "\" Then
            KoerperName = Left(KoerperName, Len(KoerperName) - 1)
        End If
        
        KoerperName = Replace(KoerperName, "\", "_")
        
        Dim oshapes
        Set oshapes = Koerper.shapes
        
        If oshapes.Count = 0 And b_mitleere = False Then
        Else
        
                'Koerper kopieren
                Activdocu.Selection.Clear
                Activdocu.Selection.Add Koerper
                Activdocu.Selection.Copy
                Activdocu.Selection.Clear
                
                'Part erzeugen und Koerper einfuegen
                On Error Resume Next
                Set PartNeu = ProductNeu.Products.AddNewComponent("Part", CStr(KoerperName))
                If Err.Number <> 0 Then
                    On Error GoTo 0
                    l = ProductNeu.Products.Count
                    Set PartNeu = ProductNeu.Products.Item(l)
                    KoerperName = KoerperName & "." & i
                    PartNeu.PartNumber = KoerperName
                    ProductNeu.Products.Item(l).Name = KoerperName & ".1"
                Else
                    On Error GoTo 0
                End If
                
                ' Fenster mit neue Product activieren
                ProductNeu.Parent.Activate
                
                ' Alle Parts suchen
                PartSuchen ProductNeu.Parent, UserSel
                
                'ProductNeu.parent.Selection.Clear
                'ProductNeu.parent.Selection.Add UserSel.Item(UserSel.Count).Value
                ProductNeu.Parent.Selection.Clear
                ProductNeu.Parent.Selection.Add ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent.Part
                ' Variante 1: Einfuegen "wie vorhanden"
                'ProductNeu.Parent.selection.Paste
                ' Variante 2: Einfuegen als "toter Solid"
                ProductNeu.Parent.Selection.PasteSpecial "CATPrtResultWithOutLink"
                ProductNeu.Parent.Selection.Clear
                
                'eingefuegten Koerper zum PartBody machen und Ex-PartBody loeschen
                Set workPart = ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent
                If workPart.Part.Bodies.Count > 1 Then
                    workPart.Part.MainBody = workPart.Part.Bodies.Item(workPart.Part.Bodies.Count)
                    ProductNeu.Parent.Selection.Add workPart.Part.Bodies.Item(1)
                    ProductNeu.Parent.Selection.Delete
                    ProductNeu.Parent.Selection.Clear
                End If
            End If
        
    Next
    

    
    ' Product actualisieren
    ProductNeu.ApplyWorkMode DESIGN_MODE
    On Error Resume Next
    ProductNeu.Update
    If Err <> 0 Then
        MsgBox "Problem with update!" & vbLf & vbLf & "Please update manual!", vbCritical + vbOKOnly, "Update-Error"
    End If
    On Error GoTo 0
    
End Sub


Sub PartSuchen(oPartDoc1, UserSel)
    
    Dim E As Object 'CATBSTR
    Dim Was(0)
    Was(0) = "Part"
    
   ' Dim UserSel As Object
    Set UserSel = oPartDoc1.Selection
    UserSel.Clear
    
    'Let us first fill the CSO with all the objects of the model
    UserSel.Search ("CATPrtSearch.PartFeature,all")
    
    'E = UserSel.SelectElement2(Was, "Alle CATPart wählen", True)
    'Letztekoerper = UserSel.Count
    
End Sub


Sub FensterNebeneinander()
    
    Dim windows1 'As Windows
    Set windows1 = CATIA.Windows
    
    windows1.Arrange catArrangeTiledVertical
    
End Sub