Dim Struktur As Product
Set Struktur = CATIA.ActiveDocument.Product

Dim selection1 As Selection
Set selection1 = CATIA.ActiveDocument.Selection

Dim documents1 As Documents
Set documents1 = CATIA.Documents

'Set oProd = selection1.Item(1).Value

'If TypeName(oProd.ReferenceProduct.Parent) = "PartDocument" Then
	
'	Dim Sammelordner as String
'	Sammelordner = oProd.ReferenceProduct.Parent.Name
	'Call TreatANode(Struktur)	
'End If
Dim Sammelordner as String
Sammelordner="collect.CATPart"
    Dim Auswahl
    Dim Check As Boolean

Sub CATMain()

	Dim otype(0)
	otype(0) = "Product"
	
	selection1.Clear
	
	Box = MsgBox("Bitte wählen Sie das Ziel-Part aus", vbInformation + vbOKCancel, "Ziel-Part auswählen")
	
	If Box = vbCancel Then
		
		Box = MsgBox("Sie haben die Selektion abgebrochen" + Chr(10) + _
		"Das Makro wird nun beendet!", vbCritical, "Abbruch durch Nutzer")
		
		Exit Sub
	End If
	
	
	Do
		Auswahl = selection1.SelectElement2(otype, "Bitte wählen Sie ein Part aus", False)
		
		If Auswahl = "Normal" Then
			
			Set oProd = selection1.Item(1).Value
			
			If TypeName(oProd.ReferenceProduct.Parent) <> "PartDocument" Then
				
				Box = MsgBox("Bitte wählen Sie das Ziel-Part aus!", vbInformation, "Falsche Auswahl")
				
			Else
				Check = True
			End If
		Else
			Box = MsgBox("Sie haben die Selektion abgebrochen" + Chr(10) + _
			"Das Makro wird nun beendet!", vbCritical, "Abbruch durch Nutzer")
			
			Exit Sub
		End If
	Loop Until Check = True
	
	selection1.Clear
	
	
'######################################################
'	Set oProd = selection1.Item(1).Value
'	MsgBox TypeName(oProd.ReferenceProduct.Parent)
	
'	If TypeName(oProd.ReferenceProduct.Parent) = "PartDocument" Then
		
		Dim Sammelordner as String
		Sammelordner = oProd.ReferenceProduct.Parent.Name
		Call TreatANode(Struktur)

'	End If


	'MsgBox selection1.item(1).reference.Name
	'MsgBox TypeName(oProd.ReferenceProduct.Parent)
	'MsgBox oProd.ReferenceProduct.Parent.Name
	
	
End Sub



Sub TreatANode(ByRef oNode)
	
	Dim iNumberOfSubComponent As Integer
	iNumberOfSubComponent = oNode.Products.Count
	
	If (iNumberOfSubComponent = 0) Then
		oNode.ApplyWorkMode DESIGN_MODE
		'MsgBox oNode.name
		'MsgBox oNode.PartNumber
		'MsgBox oNode.ReferenceProduct.Parent.Name		'Datei-Name
		'MsgBox oNode.ReferenceProduct.Parent.FullName	'Datei-Name mit Pfad
		FTFsearch (oNode.ReferenceProduct.Parent.Name)
	Else
		Dim I As Integer
		For I = 1 to iNumberOfSubComponent
			Call TreatANode(oNode.Products.Item(I))
		Next
	End If
End Sub



Sub FTFsearch(Fname as String)

	if Fname <> Sammelordner then	
		'####################################### Abfragen ob PART 
		Dim partDocument1 As Document
		Set partDocument1 = documents1.Item(Fname)
		
		Dim part1 As Part
		Set part1 = partDocument1.Part
		
		Dim GeoEbene1 As HybridBodies
		Set GeoEbene1 = part1.HybridBodies
		
		'Dim GeoSetAnz as Integer
		'GeoSetAnz = GeoEbene1.count
		
		For I = 1 to GeoEbene1.count
			if GeoEbene1.Item(I).name = "Fertigteil_Flaechen" then
				Dim GeoSetFFinhalt As HybridShapes
				Set GeoSetFFinhalt = GeoEbene1.Item(I).HybridShapes
				selection1.clear
				
				if GeoSetFFinhalt.count = 1 then
					selection1.add GeoSetFFinhalt.item(1)
					'MsgBox GeoSetFFinhalt.item(1).name
				else
					Dim pruefString as String
					For II = 1 to GeoSetFFinhalt.count
						pruefString = UCase (GeoSetFFinhalt.Item(II).name)
						pruefString = Left (pruefString,19)
						If pruefString = "FERTIGTEIL_FLAECHEN" then
							selection1.add GeoSetFFinhalt.item(II)
							'MsgBox GeoSetFFinhalt.item(II).name
						End IF
					Next
				end if
			End if
		Next
		
		selection1.Copy
		selection1.clear
		
		Dim partDocument2 As Document
		Set partDocument2 = documents1.Item(Sammelordner)
		
		Dim part2 As Part
		Set part2 = partDocument2.Part
		
		Dim GeoEbeneSO1 As HybridBodies
		Set GeoEbeneSO1 = part2.HybridBodies
		
		
		
				
		For III = 1 to GeoEbeneSO1.count
			if GeoEbeneSO1.Item(III).name = "Fertigteil_Flaechen" then
				selection1.add GeoEbeneSO1.Item(III)
				selection1.PasteSpecial "CATPrtResultWithOutLink"
				selection1.clear
				part2.UpdateObject GeoEbeneSO1.Item(III)
			end if
		Next
	End If
	
	'GSD aktivieren
	'Dim hybridShapeFactory1 As Factory
	'Set hybridShapeFactory1 = part1.HybridShapeFactory
	
	'Dim GeoSetFFinhalt As HybridShapes
	'Set GeoSetFFinhalt = hybridBody1.HybridShapes
	'MsgBox GeoSetFFinhalt.Item(1).name
End Sub