Code:
Dim documents1 As Documents
Set documents1 = CATIA.Documents
Dim partDocument1 As Document
Set partDocument1 = documents1.Item("SCHABLONE_1.CATPart")
Dim part1 As Part
Set part1 = partDocument1.Part
Dim hybridBodies1 As HybridBodies
Set hybridBodies1 = part1.HybridBodies
Dim hybridBody1 As HybridBody
Set hybridBody1 = hybridBodies1.Item("KONSTRUKTION")
Dim hybridBodies2 As HybridBodies
Set hybridBodies2 = hybridBody1.HybridBodies
Dim hybridBody2 As HybridBody
Set hybridBody2 = hybridBodies2.Item("Int")
Dim hybridBodies3 As HybridBodies
Set hybridBodies3 = hybridBody2.HybridBodies
Dim hybridBody3 As HybridBody
Set hybridBody3 = hybridBodies3.Item("Kit")
Dim hybridBodies4 As HybridBodies
Set hybridBodies4 = hybridBody3.HybridBodies
Dim hybridBody4 As HybridBody
Set hybridBody4 = hybridBodies4.Item("Kap")
Dim hybridBodies5 As HybridBodies
Set hybridBodies5 = hybridBody4.HybridBodies
Dim hybridBody5 As HybridBody
Set hybridBody5 = hybridBodies5.Item("Apm")
Dim hybridShapes1 As HybridShapes
Set hybridShapes1 = hybridBody5.HybridShapes
Dim hybridShapeCurveExplicit1 As HybridShapeSet hybridShapeCurveExplicit1 = hybridShapes1.Item("Kreis_Mitte")
Set hybridShapeCurveExplicit2 = hybridShapes1.Item("Kontur_Mitte")
Dim reference1 As Reference
Set reference1 = part1.CreateReferenceFromObject(hybridShapeCurveExplicit1)
Dim reference2 As Reference
Set reference2 = part1.CreateReferenceFromObject(hybridShapeCurveExplicit2)
Dim hybridShapeFactory1 As HybridShapeFactory
Set hybridShapeFactory1 = part1.HybridShapeFactory
Dim hybridShapeIntersection1 As HybridShapeIntersection
Set hybridShapeIntersection1 = hybridShapeFactory1.AddNewIntersection(reference1, reference2)
hybridShapeIntersection1.PointType = 1
hybridShapeIntersection1.ExtendMode = 0
hybridBody5.AppendHybridShape hybridShapeIntersection1
part1.InWorkObject = hybridShapeIntersection1
'Fehlerbehandlung ausschalten
On Error Resume Next
'Warnungen ausschalten
'CATIA.DisplayFileAlerts = False
part1.UpdateObject hybridBody5
MsgBox (Err.Number)
'Fehlerabarbeiten
If Err.Number = -2147467259 Then
MsgBox "Keine Kreuzung vorhanden"
Dim parameters1 As Parameters
Set parameters1 = part1.Parameters
Dim strParam1 As Parameter
Set strParam1 = parameters1.Item("Schablone\KONSTRUKTION\Int\Kit\Kap\Apm\Mitte")
strParam1.Value = "OK"
partDocument1.Selection.Clear
partDocument1.Selection.Add hybridShapeIntersection1
partDocument1.Selection.Delete
else
MsgBox "Schnittpunkt vorhanden!"
strParam1.Value = "zu lang"
partDocument1.Selection.Clear
partDocument1.Selection.Add hybridShapeIntersection1
partDocument1.Selection.Delete
End If
part1.UpdateObject hybridBody5
'Fehlerbehandlung einschalten
On Error GoTo 0
End sub