Code:
Public iCounter As Integer
Public myParamName As StringSub CatMain()
Dim myProductDocument As ProductDocument
Dim myProduct As Product
'Catia Dokument holen
If CATIA.Documents.Count <> 0 Then
If TypeName(CATIA.ActiveDocument) = "ProductDocument" Then
Set myProductDocument = CATIA.ActiveDocument
Else
MsgBox "Kein Produkt geladen!", vbCritical, "Warnung"
Exit Sub
End If
Else
MsgBox "Kein Dokument geöffnet!", vbCritical, "Warnung"
Exit Sub
End If
'Root Produkt aus dem Dokument holen
If myProductDocument.Product.Products.Count <> 0 Then
Set myProduct = myProductDocument.Product
Else
MsgBox "Produkt in dem aktuellen Catia Dokument ist leer!", vbCritical, "Warnung"
Exit Sub
End If
iCounter = 0 'Zähler Variable nullen
myParamName = "Material" 'Name für die Benutzereigenschaft festlegen
ScanStructure myProduct 'Prüffunktion zum finden der Parts
MsgBox "Es wurden " & iCounter & " Parts bearbeitet", vbInformation, "Hinweis"
End Sub
Sub ScanStructure(ProductToScan As Product)
Dim currentprod As Product 'Variable zum durchzählen der Produkte
Dim refProd As Product 'Referenz Produkt für die Bearbeitung
Dim refPart As Part 'Referenz Part für das Abfragen des Materials
Dim myManager As MaterialManager 'Catia Material Manager Instanz
Dim refMaterial As material 'Referenz Material für den Material Manager
Dim refParamList As Parameters
On Error Resume Next
For Each currentprod In ProductToScan.Products 'Jedes Produkt das im Produkt aus dem Aufruf enthalten ist wird geprüft
If currentprod.Products.Count > 0 Then 'Rekursion wenn im Produkt weitere Produkte sind
ScanStructure currentprod 'Übergeben wird nun das grade zu prüfende Produkt
Else
Set refProd = currentprod.ReferenceProduct 'Ab hier sind keine weiteren Produkte mehr enthalten
If TypeName(refProd.Parent) = "PartDocument" Then 'Erkennen ob in dem Produkt ein Part enthalten ist
Set refPart = refProd.Parent.Part 'Part aus dem Produkt in die Referenz Variable übergeben
Set myManager = refProd.GetItem("CATMatManagerVBExt") 'Material Manager aktivieren
myManager.GetMaterialOnPart refPart, refMaterial 'Material aus dem Part abrufen
If CheckNames(refProd.UserRefProperties) = 0 Then 'Nur wenn keine gleiche Eigenschaft vorhanden
If Not refMaterial Is Nothing Then 'Nur wenn ein Material vorhanden
Set myPropertyMaterial = refProd.UserRefProperties.CreateString(myParamName, refMaterial.Name) 'Neue Benutzereigenschaft anlegen und füllen
iCounter = iCounter + 1 'Zähler Variable eins weiter zählen
End If
End If
End If
End If
Next
End Sub
Public Function CheckNames(UsrParameters As Parameters) As Single
Dim refParam As Parameter 'Referenz Parameter zur Abfrage der Eigenschaften
For Each refParam In UsrParameters
If InStr(1, refParam.Name, myParamName, vbTextCompare) <> 0 Then 'Vergleichen ob eine Eigenschaft mit der Bezeichnung vorhanden ist
CheckNames = 1 'Eigenschaft gefunden Funktion wird vorzeitig beendet
Exit Function
End If
Next
CheckNames = 0 'Keine Eigenschaft gefunden
End Function