Dim KomponenteNeu As Products
Dim KoerperName
Dim SubPartName
Dim OpenKoerperName
Dim hybridBodies As Document
Dim Koerper  As Object
Dim QuellFenster As Window
Dim Letztekoerper
Dim UserSel As Selection
Dim NeuerKoerper As Integer
Dim FullpartName As String
Dim FullSubPartName As String
Dim FullSubPartNameTemp As String
Dim Activdocu As Document
Dim ProductNeu  As Product
Dim PartNeu As Product
Dim Schleifen As Integer
Dim Schleifenlauf As Integer
Dim k As Integer
Public SubPartInd As String
Public SubPartNr As Integer
Public AusFormat As String
Public EinFormat As String
Public MaxGroesse As Integer
Public DateiName As String
Public OrdnerName As String
Public AusgabeText As String
Public Leerkoerper As Integer
Public ProduktOffen As Integer
Public PartOffen As Integer
Public workPartDoc As Document


Sub CATMain()
       
    DS_Form.Show
    Dim documents1 As Documents
    Dim partDocument1 As Document
    
    If EinFormat = "aktuellPart" Then
        Set Activdocu = CATIA.ActiveDocument
        FullpartName = Activdocu.FullName
        Schleifen = 1
        Schleifenlauf = 1
        k = 0
    ElseIf EinFormat = "gewaehltPart" Then
        Set documents1 = CATIA.Documents
        Set partDocument1 = documents1.Open(DateiName)
        Set Activdocu = CATIA.ActiveDocument
        FullpartName = Activdocu.FullName
        Schleifen = 1
        Schleifenlauf = 1
        k = 0
    ElseIf EinFormat = "gewaehltOrdner" Then
        Dim oFileSystem As INFITF.FileSystem
        Set oFileSystem = CATIA.FileSystem
        Dim oFolder As INFITF.Folder
        Set oFolder = oFileSystem.GetFolder(OrdnerName)
        Dim j As Integer
        Dim oFile As INFITF.File
        Schleifen = oFolder.Files.Count
    End If
    
    For j = 1 To Schleifen
        
        If EinFormat = "gewaehltOrdner" Then
            Set oFile = oFolder.Files.Item(j)
            If Right(oFile.Name, 7) = "CATPart" Then
                Dim Zaehler As Integer
                Zaehler = Zaehler + 1
                Set documents1 = CATIA.Documents
                Set partDocument1 = documents1.Open(oFile.Name)
                Set Activdocu = CATIA.ActiveDocument
                If oFileSystem.FolderExists(OrdnerName & "\Gesplittet") Then
                Else
                    oFileSystem.CreateFolder (OrdnerName & "\Gesplittet")
                End If
                FullpartName = OrdnerName & "\Gesplittet\" & Activdocu.FullName
                Schleifenlauf = 1
                k = 0
            Else
                Schleifenlauf = 0
            End If
        End If
        
        If Schleifenlauf > 0 Then
            
            FullpartName = Replace(FullpartName, ".CATPart", "")
            
            '---------------------------------------------------
            ' Neue Product
            '---------------------------------------------------
            Dim PosString As Long
            
            partName = CATIA.ActiveDocument.Name
            
            Dim docu As Documents
            Set docu = CATIA.Documents
            
            Dim productDocu As Document
            Set productDocu = docu.Add("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 workPart As PartDocument
            
            NeuerKoerper = 1
            SubPartNr = 1
            
            For i = 1 To koerperAnzahl
                
                
                Set Koerper = partBodies.Item(i)
                KoerperName = Koerper.Name
                
                Dim Oshapes
                Set Oshapes = Koerper.Shapes
                
                If Oshapes.Count = 0 And Leerkoerper = 0 Then
                Else
                    If Right(KoerperName, 1) = "\" Then
                        KoerperName = Left(KoerperName, Len(KoerperName) - 1)
                    End If
                    
                    Indexkonvert
                    
                    KoerperName = Replace(KoerperName, "\", "_")
                    SubPartName = partName & SubPartInd
                    SubPartName = Replace(SubPartName, ".CATPart", "_")
            
                    If NeuerKoerper = 1 Then
                        Set PartNeu = ProductNeu.Products.AddNewComponent("Part", CStr(SubPartName))
                        NeuerKoerper = 0
                    End If
                    
                    Koerperkopieren
                    k = k + 1
                            
                    'Datei speichern
                    Dim FileSizeLng As Long
                    Dim SubFileObj As File
                    Dim FullPartNameTemp As String
                    
                    Set workPartDoc = ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent
                    
                    CATIA.DisplayFileAlerts = False
                    If AusFormat = "V4" Then
                        'Speichern als V4 Model
                        FullPartNameTemp = FullpartName & "_temp.model"
                        workPartDoc.ExportData FullPartNameTemp, "model"
                    Else
                        'Speichern als V5 CATPart
                        FullPartNameTemp = FullpartName & "_temp.CATPart"
                        workPartDoc.SaveAs FullPartNameTemp
                    End If
                    CATIA.DisplayFileAlerts = True
                    
                    'Groesse bestimmen
                    Set SubFileObj = CATIA.FileSystem.GetFile(FullPartNameTemp)
                    FileSizeLng = SubFileObj.Size
                    
                    If FileSizeLng / 1048576 > MaxGroesse Then
                        If k > 1 Then
                            Set workPart = ProductNeu.Products.Item(PartNeu).ReferenceProduct.Parent
                            ProductNeu.Parent.Selection.Add workPart.Part.Bodies.Item(workPart.Part.Bodies.Count)
                            ProductNeu.Parent.Selection.Delete
                        End If
                        
                        SaveWorkPartDoc
                                    
                        If k > 1 Then
                            SubPartNr = SubPartNr + 1
                            Indexkonvert
                            SubPartName = partName & SubPartInd
                            SubPartName = Replace(SubPartName, ".CATPart", "_")
                            Set PartNeu = ProductNeu.Products.AddNewComponent("Part", CStr(SubPartName))
                            Koerperkopieren
                        End If
                    End If
                End If
            Next
             
            SaveWorkPartDoc
                    
            CATIA.FileSystem.DeleteFile (FullPartNameTemp)
          
            ' 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
            
            If ProduktOffen = 0 Then
                productDocu.Close
            End If
            If PartOffen = 0 Then
                Activdocu.Close
            End If
        End If
        Next
End Sub

Sub SaveWorkPartDoc()
    
    'Hauptkoerper aktivieren
    Dim partWP As Part
    Set partWP = workPartDoc.Part
    Dim bodiesWP As Bodies
    Set bodiesWP = partWP.Bodies
    Dim bodyWP As Body
    Set bodyWP = bodiesWP.Item("PartBody")
    partWP.InWorkObject = bodyWP
    
    
    CATIA.DisplayFileAlerts = False
    If AusFormat = "V4" Then
        'Speichern als V4 Model
        FullSubPartName = FullpartName & "_" & SubPartInd & ".model"
        workPartDoc.ExportData FullSubPartName, "model"
    Else
        'Speichern als V5 CATPart
        FullSubPartName = FullpartName & "_" & SubPartInd & ".CATPart"
        workPartDoc.SaveAs FullSubPartName
    End If
    CATIA.DisplayFileAlerts = True
End Sub


Sub Koerperkopieren()
        'Koerper kopieren
        Activdocu.Selection.Clear
        Activdocu.Selection.Add Koerper
        Activdocu.Selection.Copy
        Activdocu.Selection.Clear
        
        'Part erzeugen und Koerper einfuegen
        On Error Resume Next
        
        If Err.Number <> 0 Then
            On Error GoTo 0
            l = ProductNeu.Products.Count
            Set PartNeu = ProductNeu.Products.Item(l)
            KoerperName = KoerperName & "." & i
            PartNeu.PartNumber = SubPartName
            ProductNeu.Products.Item(l).Name = SubPartName & ".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
        Dim documents1 As Documents
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

Sub Indexkonvert()

    If SubPartNr = 1 Then
    SubPartInd = "A"
    End If
    If SubPartNr = 2 Then
    SubPartInd = "B"
    End If
    If SubPartNr = 3 Then
    SubPartInd = "C"
    End If
    If SubPartNr = 4 Then
    SubPartInd = "D"
    End If
    If SubPartNr = 5 Then
    SubPartInd = "E"
    End If
    If SubPartNr = 6 Then
    SubPartInd = "F"
    End If
    If SubPartNr = 7 Then
    SubPartInd = "G"
    End If
    If SubPartNr = 8 Then
    SubPartInd = "H"
    End If
    If SubPartNr = 9 Then
    SubPartInd = "I"
    End If
    If SubPartNr = 10 Then
    SubPartInd = "J"
    End If
    If SubPartNr = 11 Then
    SubPartInd = "K"
    End If
    If SubPartNr = 12 Then
    SubPartInd = "L"
    End If
    If SubPartNr = 13 Then
    SubPartInd = "M"
    End If
    If SubPartNr = 14 Then
    SubPartInd = "N"
    End If
    If SubPartNr = 15 Then
    SubPartInd = "O"
    End If
    If SubPartNr = 16 Then
    SubPartInd = "P"
    End If
    If SubPartNr = 17 Then
    SubPartInd = "Q"
    End If
    If SubPartNr = 18 Then
    SubPartInd = "R"
    End If
    If SubPartNr = 19 Then
    SubPartInd = "S"
    End If
    If SubPartNr = 20 Then
    SubPartInd = "T"
    End If
    If SubPartNr = 21 Then
    SubPartInd = "U"
    End If
    If SubPartNr = 22 Then
    SubPartInd = "V"
    End If
    If SubPartNr = 23 Then
    SubPartInd = "W"
    End If
    If SubPartNr = 24 Then
    SubPartInd = "X"
    End If
    If SubPartNr = 25 Then
    SubPartInd = "Y"
    End If
    If SubPartNr = 26 Then
    SubPartInd = "Z"
    End If
  
End Sub