'------------------------------------------------------------
' Makroname = PARTtoPRODUCT_R16_V3.CATScript
'
'
' Author:   Filippo Gozza
' Version:  V5R10, V5R12
'
' angapsst an V5R16
'------------------------------------------------------------
' Konvertiert ein CATAllPart in ein CATProduct
' Alle Körper werden in CATPart's konvertiert
' Alle Geometrical Sets werden in ein CATPart konvertiert
'------------------------------------------------------------
Option Explicit

Language = "VBSCRIPT"

Dim KomponenteNeu 			'As products
Dim KoerperName
Dim OpenKoerperName
Dim partBodies 				'As Document
Dim Koerper  				'As Object
Dim QuellFenster 			'As Window
Dim Letztekoerper
Dim UserSel 				'As Selection


Sub CATMain()

    Dim Activdocu 			' As Document
	Dim partName
	DIm I 					' As Integer
	Dim docu 				'As documents
    Dim productDocu 		'As Document
	Dim ProductNeu  		'As Product
	Dim koerperAnzahl
	Dim partBodies 			'As Bodies
	Dim UserSel 			'As Object
	Dim PartNeu 			'As Product
	Dim GeoSet				'As Hybridbody
	Dim GeoSets
	Dim GeoSetName			' As String
	Dim GeoCount			'As Integer
	Dim StrLine				' As String
	Dim Box					' Für Message Boxen
	DIm count				' as Integer
	DIm visPropertySet1
	
	
	Set Activdocu = CATIA.ActiveDocument
    
    '---------------------------------------------------
    ' Neue Product
    '---------------------------------------------------

    partName = CATIA.ActiveDocument.name
    Set docu = CATIA.documents
    Set productDocu = docu.Add("Product")
    Set ProductNeu = productDocu.Product

    ProductNeu.PartNumber = partName

    '------------------------------------------------------
    call FensterNebeneinander ()

    Set QuellFenster = CATIA.Windows.Item(1)
    QuellFenster.Activate
    Set partBodies = Activdocu.part.Bodies


    koerperAnzahl = partBodies.Count
	
	' Part Bodys
    For I = 1 To koerperAnzahl

        Set Koerper = partBodies.Item(I)
        KoerperName = Koerper.name

        'Koerper kopieren
        Activdocu.Selection.Clear 
	    Activdocu.Selection.Add Koerper
        Activdocu.Selection.Copy
        Activdocu.Selection.Clear

        'Part erzeugen und Koerper einfuegen
        Set PartNeu = ProductNeu.products.AddNewComponent("Part", CStr(KoerperName&"_"&I))

        ' Fenster mit neue Product activieren
        ProductNeu.parent.Activate

        ' Alle Parts suchen
        PartSuchen ProductNeu.parent, UserSel

        ProductNeu.parent.Selection.Paste
        ProductNeu.parent.Selection.Clear
        
    Next
	
	set GeoSets = Activdocu.part.HybridBodies
	GeoCount = GeoSets.count
	
	' Geometrical Sets
    For I = 1 To GeoCount
		Dim ergebnis
		Dim GeoSetNameRed	'As String
		DIm laenge			' as Integer
		
        Set GeoSet = GeoSets.Item(I)
        GeoSetName = GeoSet.name
		
		' kürzen des Namens vom Ende bis zum letzten "\" im Namen
		ergebnis = InStr(GeoSetName, "\")
		GeoSetNameRed=GeoSetName
		
		Do while ergebnis > 0
			laenge = len (GeoSetNameRed)
			GeoSetNameRed = right(GeoSetNameRed, laenge-ergebnis)
			ergebnis = InStr(GeoSetNameRed, "\")
		loop
		
        'Koerper kopieren
        Activdocu.Selection.Clear 
	    Activdocu.Selection.Add GeoSet
    
        Activdocu.Selection.Copy
        Activdocu.Selection.Clear

        'Part erzeugen und Koerper einfuegen
        Set PartNeu = ProductNeu.products.AddNewComponent("Part", CStr(GeoSetNameRed&"_"&I)) ' & I ist notwendig, damit der PartName eindeutig bleibt.

        ' Fenster mit neue Product activieren
        ProductNeu.parent.Activate

        ' Alle Parts suchen
        call PartSuchen ( ProductNeu.parent, UserSel)

        ProductNeu.parent.Selection.Paste
        ProductNeu.parent.Selection.Clear
		
    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

	' verdecken der Ebenen in den neuen Parts! (alle Ebenen)
	Dim selection1 As Selection
	Set selection1 = Activdocu.Selection
	selection1.Search "(((CATStFreeStyleSearch.Plane + CATPrtSearch.Plane) + CATGmoSearch.Plane) + CATSpdSearch.Plane),all"
	COUNT=selection1.count
	BOX = msgbox( " "&COUNT&" Planes selected, all will be hidden",65,"Information")

	' bricht das Makro ab, wenn Abrechen geklickt wird
	if BOX = 2 then
		exit Sub
	end if
	' verdecken der Planes
	Set visPropertySet1 = selection1.VisProperties 
	visPropertySet1.SetShow 1
		
	' Abschlussmeldung / Statistik
	StrLine="Worked on " & vblf
	StrLine=StrLine & "PartBodys	: " & koerperAnzahl &vblf
	StrLine=StrLine & "Geometrical Sets	: " & GeoCount& vblf
	StrLine=StrLine & "copied to new Parts."&vblf
	StrLine=StrLine & vblf
	StrLine=StrLine & "Please Save with Savemanagemen."
	box = msgbox (StrLine,64,"Result")
	
End Sub


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


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